diff --git a/InitCode.pas b/InitCode.pas index 0d665b3..d98df42 100644 --- a/InitCode.pas +++ b/InitCode.pas @@ -7,8 +7,7 @@ uses System.SysUtils; const - PluginsParam1 = '--basedir='; - PluginsParam2 = '-bd'; + PluginsParam = '-bd'; type PUIFuncs = ^TUIFuncs; @@ -31,6 +30,7 @@ type end; var + DEBUG: Boolean = False; UILib: TLibImport; PluginsPath: String = ''; XTLUI1: procedure; @@ -65,6 +65,18 @@ var initialization +IsLibrary := ExtractFileName(Utils.GetModuleName) <> + ExtractFileName(ParamStr(0)); +if IsLibrary then + exit; +for I := 1 to ParamCount do +begin + if (ParamStr(I) = '--debug') then + begin + DEBUG := True; + break; + end; +end; Init; if UIDLLLoaded and (ParamCount = 0) then PluginsPath := IncludeTrailingBackSlash @@ -72,14 +84,9 @@ if UIDLLLoaded and (ParamCount = 0) then ChangeFileExt(Utils.GetModuleName, 'ui.ini')))); for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(PluginsParam1) then + if ParamStr(I).StartsWith(PluginsParam) then begin - PluginsPath := ParamStr(I).Substring(PluginsParam1.Length); - break; - end; - if ParamStr(I).StartsWith(PluginsParam2) then - begin - PluginsPath := ParamStr(I).Substring(PluginsParam2.Length); + PluginsPath := ParamStr(I).Substring(PluginsParam.Length); break; end; end; diff --git a/Unit1.fmx b/Unit1.fmx index a4406e3..4548b21 100644 --- a/Unit1.fmx +++ b/Unit1.fmx @@ -3,8 +3,8 @@ object Form1: TForm1 Top = 0 BorderIcons = [biSystemMenu, biMinimize] BorderStyle = Single - Caption = 'XTool' - ClientHeight = 517 + Caption = 'XTool - The Ultimate Repacking Tool' + ClientHeight = 486 ClientWidth = 592 Position = ScreenCenter StyleBook = StyleBook1 @@ -3349,680 +3349,2807 @@ object Form1: TForm1 6C6C626172626F74746F6D627574746F6E085461624F72646572020000000000} end> Left = 472 - Top = 72 + Top = 264 end object SaveDialog1: TSaveDialog - Left = 368 - Top = 56 + Left = 352 + Top = 224 end object OpenDialog1: TOpenDialog - Left = 208 - Top = 96 + Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing] + Left = 400 + Top = 232 end - object Layout4: TLayout - Align = Bottom - Margins.Bottom = 8.000000000000000000 - Position.Y = 487.000000000000000000 + object TabControl1: TTabControl + Align = Client Size.Width = 592.000000000000000000 - Size.Height = 22.000000000000000000 + Size.Height = 486.000000000000000000 Size.PlatformDefault = False - TabOrder = 3 - object Button1: TButton - Align = Right - ModalResult = 1 - Margins.Left = 8.000000000000000000 - Margins.Right = 16.000000000000000000 - Position.X = 496.000000000000000000 - Size.Width = 80.000000000000000000 + TabIndex = 0 + TabOrder = 7 + TabPosition = PlatformDefault + Sizes = ( + 592s + 464s + 592s + 464s + 592s + 464s) + object TabItem1: TTabItem + CustomIcon = < + item + end> + IsSelected = True + Size.Width = 99.000000000000000000 Size.Height = 22.000000000000000000 Size.PlatformDefault = False - TabOrder = 1 - Text = 'Start' - OnClick = Button1Click - end - object Label5: TLabel - Align = Left - Margins.Left = 16.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 16.000000000000000000 - Size.Width = 96.000000000000000000 - Size.Height = 22.000000000000000000 - Size.PlatformDefault = False - Text = 'Base directory' - TabOrder = 2 - end - object Edit6: TEdit - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Client + StyleLookup = '' TabOrder = 0 - Size.Width = 368.000000000000000000 - Size.Height = 22.000000000000000000 - Size.PlatformDefault = False - object SearchEditButton5: TSearchEditButton - CanFocus = False - Cursor = crArrow - Size.Width = 28.000000000000000000 - Size.Height = 16.000000000000000000 + Text = 'Precompressor' + ExplicitSize.cx = 99.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox1: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 418.000000000000000000 Size.PlatformDefault = False TabOrder = 0 - OnClick = SearchEditButton5Click - end - end - end - object PopupMenu1: TPopupMenu - Left = 368 - Top = 450 - object MenuItem1: TMenuItem - Text = 'MenuItem1' - end - end - object VertScrollBox1: TVertScrollBox - Align = Client - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 576.000000000000000000 - Size.Height = 471.000000000000000000 - Size.PlatformDefault = False - TabOrder = 0 - Viewport.Width = 576.000000000000000000 - Viewport.Height = 471.000000000000000000 - object GroupBox1: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Input' - TabOrder = 7 - object Layout1: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Edit1: TEdit - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Client - TabOrder = 0 - ReadOnly = True + Viewport.Width = 576.000000000000000000 + Viewport.Height = 418.000000000000000000 + object GroupBox1: TGroupBox + Align = Top Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 456.000000000000000000 - Size.Height = 20.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 Size.PlatformDefault = False - object SearchEditButton1: TSearchEditButton - CanFocus = False - Cursor = crArrow - Size.Width = 28.000000000000000000 - Size.Height = 14.000000000000000000 + Text = 'Input' + TabOrder = 6 + object Layout1: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 Size.PlatformDefault = False - TabOrder = 0 - OnClick = SearchEditButton1Click + TabOrder = 14 + object Edit1: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton1: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton1Click + end + end + object ComboBox2: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory' + 'URL') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox2Change + end end end - object ComboBox2: TComboBox - Align = Left - Items.Strings = ( - 'File' - 'Directory' - 'URL') - ItemIndex = 0 + object GroupBox2: TGroupBox + Align = Top Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 + Margins.Right = 8.000000000000000000 Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 80.000000000000000000 - Size.Height = 20.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 90.000000000000000000 Size.PlatformDefault = False - TabOrder = 1 - OnChange = ComboBox2Change - end - end - end - object GroupBox2: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 108.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 90.000000000000000000 - Size.PlatformDefault = False - Text = 'Options' - TabOrder = 3 - object Layout3: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 15 - object Label1: TLabel - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - Text = 'Chunk size (MB)' - TabOrder = 1 - end - object SpinBox1: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Left + Text = 'Options' TabOrder = 3 - Cursor = crIBeam - DecimalDigits = 0 - Min = 16.000000000000000000 - Max = 1792.000000000000000000 - Value = 16.000000000000000000 - Increment = 16.000000000000000000 - Position.X = 116.000000000000000000 - Position.Y = 8.000000000000000000 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False + object Layout3: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 15 + object Label1: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Chunk size' + TabOrder = 3 + end + object SpinBox1: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 5 + Cursor = crIBeam + DecimalDigits = 0 + Min = 16.000000000000000000 + Max = 1792.000000000000000000 + Value = 16.000000000000000000 + Increment = 16.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label2: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 2 + end + object SpinBox2: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 4 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 272.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label3: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 360.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Depth' + TabOrder = 1 + end + object SpinBox3: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 0 + Cursor = crIBeam + DecimalDigits = 0 + Max = 63.000000000000000000 + Position.X = 448.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + object Layout2: TLayout + Align = Top + Position.Y = 52.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object CheckBox2: TCheckBox + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 244.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 110.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + Text = 'Skip verification' + end + object CheckBox6: TCheckBox + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 126.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 110.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Verbose' + end + object CheckBox1: TCheckBox + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 110.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 4 + Text = 'Low memory' + end + end end - object Label2: TLabel - Align = Left + object GroupBox3: TGroupBox + Align = Top Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 224.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - Text = 'Threads' - TabOrder = 0 - end - object SpinBox2: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Left - TabOrder = 2 - Cursor = crIBeam - DecimalDigits = 0 - Min = 1.000000000000000000 - Max = 1.000000000000000000 - Value = 1.000000000000000000 - Position.X = 332.000000000000000000 - Position.Y = 8.000000000000000000 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - end - object CheckBox1: TCheckBox - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 440.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 4 - Text = 'Low memory' - end - end - object Layout2: TLayout - Align = Top - Position.Y = 52.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Label3: TLabel - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 + Margins.Right = 8.000000000000000000 Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 Size.PlatformDefault = False - Text = 'Depth' + Text = 'Output (Optional)' TabOrder = 0 + object Layout7: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit3: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton3: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton3Click + end + end + object ComboBox3: TComboBox + Align = Left + Items.Strings = ( + 'None' + 'File') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox3Change + end + end end - object SpinBox3: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Left + object GroupBox4: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 306.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Deduplication' + TabOrder = 2 + object Layout6: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 12 + object Label4: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 100.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Srep method' + TabOrder = 3 + end + object SpinBox4: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 0 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 5.000000000000000000 + Value = 3.000000000000000000 + Position.X = 204.000000000000000000 + Position.Y = 8.000000000000000000 + Enabled = False + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object ComboBox5: TComboBox + Align = Left + Items.Strings = ( + 'Disabled' + 'Internal' + 'Srep') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox5Change + end + object ComboEdit1: TComboEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 4 + ItemHeight = 19.000000000000000000 + Items.Strings = ( + '25GB' + '50GB' + '100GB' + '200GB' + '500GB') + ItemIndex = 2 + Text = '100GB' + Position.X = 400.000000000000000000 + Position.Y = 8.000000000000000000 + Enabled = False + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label6: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 292.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 100.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Srep input' + TabOrder = 2 + end + end + end + object GroupBox5: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 360.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Compression' TabOrder = 1 - Cursor = crIBeam - DecimalDigits = 0 - Max = 63.000000000000000000 - Position.X = 116.000000000000000000 - Position.Y = 8.000000000000000000 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False + object Layout8: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label7: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 100.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Compression level' + TabOrder = 0 + end + object SpinBox7: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 1 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 10.000000000000000000 + Value = 6.000000000000000000 + Position.X = 204.000000000000000000 + Position.Y = 8.000000000000000000 + Enabled = False + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object CheckBox4: TCheckBox + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 3 + Text = 'Enable' + OnChange = CheckBox4Change + end + object Label21: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 292.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 100.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Dictionary' + TabOrder = 2 + end + object ComboEdit2: TComboEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 4 + ItemHeight = 19.000000000000000000 + Items.Strings = ( + 'Auto' + '16MB' + '32MB' + '64MB' + '128MB' + '256MB' + '512MB' + '1024MB') + ItemIndex = 0 + Text = 'Auto' + Position.X = 400.000000000000000000 + Position.Y = 8.000000000000000000 + Enabled = False + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end end - object CheckBox2: TCheckBox - Align = Left + object GroupBox6: TGroupBox + Align = Top Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 224.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 140.000000000000000000 - Size.Height = 20.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 198.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 Size.PlatformDefault = False + Text = 'Method' + TabOrder = 4 + object Layout5: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit2: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Button2: TButton + Align = Right + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 472.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + Text = 'Configure' + OnClick = Button2Click + end + end + end + object GroupBox8: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 252.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Library checker' TabOrder = 5 - Text = 'Skip verification' - end - object CheckBox6: TCheckBox - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 372.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 140.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 4 - Text = 'Verbose' - end - end - end - object GroupBox3: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 54.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Output' - TabOrder = 0 - object Layout7: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Edit3: TEdit - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Client - TabOrder = 0 - ReadOnly = True - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 456.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - object SearchEditButton3: TSearchEditButton - CanFocus = False - Cursor = crArrow - Size.Width = 28.000000000000000000 - Size.Height = 14.000000000000000000 + object Layout10: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 Size.PlatformDefault = False - TabOrder = 0 - OnClick = SearchEditButton3Click + TabOrder = 14 + object Edit5: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Enabled = False + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton4: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton4Click + end + end + object ComboBox4: TComboBox + Align = Left + Items.Strings = ( + 'Disabled' + 'LZ4' + 'ZSTD' + 'Oodle') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox4Change + end end end - object ComboBox3: TComboBox - Align = Left - Items.Strings = ( - 'File' - 'None') - ItemIndex = 0 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 80.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 1 - OnChange = ComboBox3Change - end end - end - object GroupBox4: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 360.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Deduplication' - TabOrder = 2 - object Layout6: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 + object Layout4: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 434.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 Size.PlatformDefault = False - TabOrder = 12 - object CheckBox3: TCheckBox - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 2 - Text = 'Enable' - end - object Label4: TLabel - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 116.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - Text = 'Srep method' - TabOrder = 1 - end - object SpinBox4: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Left - TabOrder = 0 - Cursor = crIBeam - DecimalDigits = 0 - Max = 5.000000000000000000 - Value = 3.000000000000000000 - Position.X = 224.000000000000000000 - Position.Y = 8.000000000000000000 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - end - end - end - object GroupBox5: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 414.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Compression' - TabOrder = 1 - object Layout8: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Label7: TLabel - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 116.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - Text = 'Compression level' - TabOrder = 0 - end - object SpinBox7: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Left - TabOrder = 1 - Cursor = crIBeam - DecimalDigits = 0 - Min = 1.000000000000000000 - Max = 10.000000000000000000 - Value = 6.000000000000000000 - Position.X = 224.000000000000000000 - Position.Y = 8.000000000000000000 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - end - object CheckBox5: TCheckBox - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 332.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 160.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 2 - Text = 'High compression mode' - end - object CheckBox4: TCheckBox - Align = Left - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 100.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 3 - Text = 'Enable' - end - end - end - object GroupBox6: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 198.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Method' - TabOrder = 4 - object Layout5: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Edit2: TEdit - Touch.InteractiveGestures = [LongTap, DoubleTap] - Align = Client - TabOrder = 0 - ReadOnly = True - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 456.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - end - object Button2: TButton + TabOrder = 2 + object Button1: TButton Align = Right - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 472.000000000000000000 - Position.Y = 8.000000000000000000 + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 Size.Width = 80.000000000000000000 - Size.Height = 20.000000000000000000 + Size.Height = 22.000000000000000000 Size.PlatformDefault = False TabOrder = 1 - Text = 'Configure' - OnClick = Button2Click + Text = 'Start' + OnClick = Button1Click end - end - end - object GroupBox7: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 306.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 - Size.PlatformDefault = False - Text = 'Database' - TabOrder = 6 - object Layout9: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 - Size.PlatformDefault = False - TabOrder = 14 - object Edit4: TEdit + object Label5: TLabel + Align = Left + Margins.Left = 16.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 16.000000000000000000 + Size.Width = 96.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + Text = 'Base directory' + TabOrder = 2 + end + object Edit6: TEdit Touch.InteractiveGestures = [LongTap, DoubleTap] Align = Client TabOrder = 0 - ReadOnly = True - Enabled = False - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 456.000000000000000000 - Size.Height = 20.000000000000000000 + Size.Width = 368.000000000000000000 + Size.Height = 22.000000000000000000 Size.PlatformDefault = False - object SearchEditButton2: TSearchEditButton + object SearchEditButton5: TSearchEditButton CanFocus = False Cursor = crArrow Size.Width = 28.000000000000000000 - Size.Height = 14.000000000000000000 + Size.Height = 16.000000000000000000 Size.PlatformDefault = False TabOrder = 0 - OnClick = SearchEditButton2Click + OnClick = SearchEditButton5Click end end - object ComboBox1: TComboBox - Align = Left - Items.Strings = ( - 'Disabled' - 'Internal' - 'Generate' - 'Load') - ItemIndex = 0 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 80.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 1 - OnChange = ComboBox1Change - end end end - object GroupBox8: TGroupBox - Align = Top - Margins.Left = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 252.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 54.000000000000000000 + object TabItem2: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 119.000000000000000000 + Size.Height = 22.000000000000000000 Size.PlatformDefault = False - Text = 'Library checker' - TabOrder = 5 - object Layout10: TLayout - Align = Top - Margins.Top = 16.000000000000000000 - Position.Y = 16.000000000000000000 - Size.Width = 560.000000000000000000 - Size.Height = 36.000000000000000000 + StyleLookup = '' + TabOrder = 0 + Text = 'Data management' + ExplicitSize.cx = 119.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object TabControl2: TTabControl + Align = Client + Size.Width = 592.000000000000000000 + Size.Height = 464.000000000000000000 Size.PlatformDefault = False - TabOrder = 14 - object Edit5: TEdit + TabIndex = 0 + TabOrder = 5 + TabPosition = PlatformDefault + Sizes = ( + 592s + 442s + 592s + 442s + 592s + 442s + 592s + 442s + 592s + 442s + 592s + 442s) + object TabItem8: TTabItem + CustomIcon = < + item + end> + IsSelected = True + Size.Width = 60.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Archive' + ExplicitSize.cx = 60.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object Layout19: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + object Button6: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button6Click + end + end + object VertScrollBox3: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox13: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 337.000000000000000000 + Size.PlatformDefault = False + Text = 'Files' + TabOrder = 6 + object Layout15: TLayout + Align = Client + Margins.Top = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 285.000000000000000000 + Size.PlatformDefault = False + TabOrder = 15 + object Memo1: TMemo + Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] + DataDetectorTypes = [] + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 277.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Viewport.Width = 540.000000000000000000 + Viewport.Height = 273.000000000000000000 + end + end + object Layout17: TLayout + Align = Bottom + Position.Y = 301.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Button3: TButton + Align = Right + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 384.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + Text = 'Add file' + OnClick = Button3Click + end + object Button4: TButton + Align = Right + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 472.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Add folder' + OnClick = Button4Click + end + object Label11: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 225.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Wildcards can be used.' + TabOrder = 2 + end + end + end + object GroupBox14: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 337.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output' + TabOrder = 0 + object Layout16: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit11: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton10: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton10Click + end + end + end + end + end + end + object TabItem9: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 70.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Database' + ExplicitSize.cx = 70.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox7: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox28: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input' + TabOrder = 5 + object Layout36: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit21: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton20: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton20Click + end + end + object ComboBox19: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox19Change + end + end + end + object GroupBox29: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output' + TabOrder = 0 + object Layout37: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit22: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton21: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton21Click + end + end + end + end + object GroupBox30: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout38: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label18: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Chunk size' + TabOrder = 1 + end + object SpinBox15: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 3 + Cursor = crIBeam + DecimalDigits = 0 + Min = 16.000000000000000000 + Max = 1792.000000000000000000 + Value = 16.000000000000000000 + Increment = 16.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label19: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox16: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 2 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 272.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + object GroupBox31: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 8 + object Layout39: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit23: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton22: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton22Click + end + end + object ComboBox21: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox21Change + end + end + end + object GroupBox32: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 216.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Method' + TabOrder = 4 + object Layout40: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit24: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + end + object Layout41: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button10: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button10Click + end + end + end + object TabItem4: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 43.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Find' + ExplicitSize.cx = 43.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox2: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox10: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input' + TabOrder = 5 + object Layout12: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit8: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton7: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton7Click + end + end + object ComboBox7: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox7Change + end + end + end + object GroupBox11: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output (Optional)' + TabOrder = 0 + object Layout13: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit9: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton8: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton8Click + end + end + object ComboBox8: TComboBox + Align = Left + Items.Strings = ( + 'None' + 'File') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox8Change + end + end + end + object GroupBox12: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout14: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label9: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Chunk size' + TabOrder = 1 + end + object SpinBox6: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 3 + Cursor = crIBeam + DecimalDigits = 0 + Min = 16.000000000000000000 + Max = 1792.000000000000000000 + Value = 16.000000000000000000 + Increment = 16.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label10: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox8: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 2 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 272.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + object GroupBox9: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 8 + object Layout11: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit7: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton6: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton6Click + end + end + object ComboBox6: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox6Change + end + end + end + end + object Layout18: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button5: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button5Click + end + end + end + object TabItem5: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 48.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Erase' + ExplicitSize.cx = 48.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox4: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox15: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input' + TabOrder = 5 + object Layout20: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit10: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton9: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton9Click + end + end + object ComboBox9: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox9Change + end + end + end + object GroupBox16: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output (Optional)' + TabOrder = 0 + object Layout21: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit12: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton11: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton11Click + end + end + object ComboBox10: TComboBox + Align = Left + Items.Strings = ( + 'None' + 'File') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox10Change + end + end + end + object GroupBox17: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout22: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label12: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Chunk size' + TabOrder = 1 + end + object SpinBox9: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 3 + Cursor = crIBeam + DecimalDigits = 0 + Min = 16.000000000000000000 + Max = 1792.000000000000000000 + Value = 16.000000000000000000 + Increment = 16.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label13: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox10: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 2 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 272.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + object GroupBox18: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 8 + object Layout23: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit13: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton12: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton12Click + end + end + object ComboBox11: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox11Change + end + end + end + end + object Layout24: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button7: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button7Click + end + end + end + object TabItem6: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 61.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Replace' + ExplicitSize.cx = 61.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox5: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox19: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input (Original)' + TabOrder = 6 + object Layout25: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit14: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton13: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton13Click + end + end + object ComboBox12: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox12Change + end + end + end + object GroupBox20: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output (Optional)' + TabOrder = 0 + object Layout26: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit15: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton14: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton14Click + end + end + object ComboBox13: TComboBox + Align = Left + Items.Strings = ( + 'None' + 'File') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox13Change + end + end + end + object GroupBox21: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 216.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout27: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label14: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Chunk size' + TabOrder = 1 + end + object SpinBox11: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 3 + Cursor = crIBeam + DecimalDigits = 0 + Min = 16.000000000000000000 + Max = 1792.000000000000000000 + Value = 16.000000000000000000 + Increment = 16.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object Label15: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox12: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 2 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 272.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + object GroupBox22: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 9 + object Layout28: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit16: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton15: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton15Click + end + end + object ComboBox14: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox14Change + end + end + end + object GroupBox23: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input (New)' + TabOrder = 5 + object Layout30: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit17: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton16: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton16Click + end + end + object ComboBox15: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox15Change + end + end + end + end + object Layout29: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button8: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button8Click + end + end + end + object TabItem7: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 49.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Patch' + ExplicitSize.cx = 49.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox6: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 396.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 396.000000000000000000 + object GroupBox24: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input' + TabOrder = 5 + object Layout31: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit18: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton17: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton17Click + end + end + object ComboBox16: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox16Change + end + end + end + object GroupBox25: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output' + TabOrder = 0 + object Layout32: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit19: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton18: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton18Click + end + end + end + end + object GroupBox26: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout33: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label17: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox14: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 1 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + end + end + object GroupBox27: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 8 + object Layout34: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit20: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton19: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton19Click + end + end + end + end + end + object Layout35: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 412.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button9: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Text = 'Start' + OnClick = Button9Click + end + end + end + end + end + object TabItem3: TTabItem + CustomIcon = < + item + end> + IsSelected = False + Size.Width = 61.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + StyleLookup = '' + TabOrder = 0 + Text = 'Decode' + ExplicitSize.cx = 61.000000000000000000 + ExplicitSize.cy = 22.000000000000000000 + object VertScrollBox8: TVertScrollBox + Align = Client + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 576.000000000000000000 + Size.Height = 418.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Viewport.Width = 576.000000000000000000 + Viewport.Height = 418.000000000000000000 + object GroupBox33: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Input' + TabOrder = 5 + object Layout42: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit25: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 544.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton23: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton23Click + end + end + end + end + object GroupBox34: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Output' + TabOrder = 0 + object Layout43: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit26: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton24: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton24Click + end + end + object ComboBox18: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox18Change + end + end + end + object GroupBox35: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 162.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Options' + TabOrder = 2 + object Layout44: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Label16: TLabel + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Threads' + TabOrder = 0 + end + object SpinBox13: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Left + TabOrder = 1 + Cursor = crIBeam + DecimalDigits = 0 + Min = 1.000000000000000000 + Max = 1.000000000000000000 + Value = 1.000000000000000000 + Position.X = 96.000000000000000000 + Position.Y = 8.000000000000000000 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + end + object CheckBox7: TCheckBox + Align = Left + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 184.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 110.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 3 + Text = 'Verbose' + end + end + end + object GroupBox36: TGroupBox + Align = Top + Margins.Left = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 54.000000000000000000 + Size.PlatformDefault = False + Text = 'Source' + TabOrder = 8 + object Layout45: TLayout + Align = Top + Margins.Top = 16.000000000000000000 + Position.Y = 16.000000000000000000 + Size.Width = 560.000000000000000000 + Size.Height = 36.000000000000000000 + Size.PlatformDefault = False + TabOrder = 14 + object Edit27: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Align = Client + TabOrder = 0 + ReadOnly = True + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Right = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Size.Width = 456.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + object SearchEditButton25: TSearchEditButton + CanFocus = False + Cursor = crArrow + Size.Width = 28.000000000000000000 + Size.Height = 14.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + OnClick = SearchEditButton25Click + end + end + object ComboBox17: TComboBox + Align = Left + Items.Strings = ( + 'File' + 'Directory') + ItemIndex = 0 + Margins.Left = 8.000000000000000000 + Margins.Top = 8.000000000000000000 + Margins.Bottom = 8.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + OnChange = ComboBox17Change + end + end + end + end + object Layout46: TLayout + Align = Bottom + Margins.Bottom = 8.000000000000000000 + Position.Y = 434.000000000000000000 + Size.Width = 592.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + object Button11: TButton + Align = Right + ModalResult = 1 + Margins.Left = 8.000000000000000000 + Margins.Right = 16.000000000000000000 + Position.X = 496.000000000000000000 + Size.Width = 80.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + Text = 'Start' + OnClick = Button11Click + end + object Label20: TLabel + Align = Left + Margins.Left = 16.000000000000000000 + Margins.Right = 8.000000000000000000 + Position.X = 16.000000000000000000 + Size.Width = 96.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + Text = 'Base directory' + TabOrder = 3 + end + object Edit28: TEdit Touch.InteractiveGestures = [LongTap, DoubleTap] Align = Client TabOrder = 0 - ReadOnly = True - Enabled = False - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Right = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Size.Width = 456.000000000000000000 - Size.Height = 20.000000000000000000 + Size.Width = 368.000000000000000000 + Size.Height = 22.000000000000000000 Size.PlatformDefault = False - object SearchEditButton4: TSearchEditButton + object SearchEditButton26: TSearchEditButton CanFocus = False Cursor = crArrow Size.Width = 28.000000000000000000 - Size.Height = 14.000000000000000000 + Size.Height = 16.000000000000000000 Size.PlatformDefault = False TabOrder = 0 - OnClick = SearchEditButton4Click + OnClick = SearchEditButton5Click end end - object ComboBox4: TComboBox - Align = Left - Items.Strings = ( - 'Disabled' - 'LZ4' - 'ZSTD' - 'Oodle') - ItemIndex = 0 - Margins.Left = 8.000000000000000000 - Margins.Top = 8.000000000000000000 - Margins.Bottom = 8.000000000000000000 - Position.X = 8.000000000000000000 - Position.Y = 8.000000000000000000 - Size.Width = 80.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - TabOrder = 1 - OnChange = ComboBox4Change - end end end end + object OpenDialog2: TOpenDialog + Options = [ofHideReadOnly, ofAllowMultiSelect, ofPathMustExist, ofFileMustExist, ofShareAware, ofEnableSizing] + Left = 264 + Top = 253 + end + object SaveDialog2: TSaveDialog + DefaultExt = 'xtl' + Filter = 'Database files (*.xtl)|*.xtl' + Left = 448 + Top = 280 + end end diff --git a/Unit1.pas b/Unit1.pas index 30aaefa..77d415f 100644 --- a/Unit1.pas +++ b/Unit1.pas @@ -8,15 +8,14 @@ uses System.Variants, System.Math, System.StrUtils, System.IniFiles, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TabControl, FMX.Layouts, FMX.ListBox, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Edit, - FMX.EditBox, FMX.SpinBox, FMX.Menus; + FMX.EditBox, FMX.SpinBox, FMX.Menus, FMX.ComboEdit, FMX.Memo.Types, + FMX.ScrollBox, FMX.Memo; type TForm1 = class(TForm) StyleBook1: TStyleBook; SaveDialog1: TSaveDialog; OpenDialog1: TOpenDialog; - Layout4: TLayout; - Button1: TButton; GroupBox1: TGroupBox; ComboBox2: TComboBox; Edit1: TEdit; @@ -34,42 +33,215 @@ type SpinBox1: TSpinBox; Label2: TLabel; SpinBox2: TSpinBox; - CheckBox1: TCheckBox; Layout2: TLayout; - Label3: TLabel; - SpinBox3: TSpinBox; GroupBox4: TGroupBox; Layout6: TLayout; GroupBox5: TGroupBox; Layout8: TLayout; Label7: TLabel; SpinBox7: TSpinBox; - CheckBox5: TCheckBox; - CheckBox3: TCheckBox; Label4: TLabel; SpinBox4: TSpinBox; CheckBox4: TCheckBox; - PopupMenu1: TPopupMenu; - MenuItem1: TMenuItem; GroupBox6: TGroupBox; Layout5: TLayout; Edit2: TEdit; Button2: TButton; - GroupBox7: TGroupBox; - Layout9: TLayout; - Edit4: TEdit; - SearchEditButton2: TSearchEditButton; - ComboBox1: TComboBox; CheckBox2: TCheckBox; - CheckBox6: TCheckBox; GroupBox8: TGroupBox; Layout10: TLayout; Edit5: TEdit; SearchEditButton4: TSearchEditButton; ComboBox4: TComboBox; + ComboBox5: TComboBox; + ComboEdit1: TComboEdit; + Label6: TLabel; + TabControl1: TTabControl; + TabItem1: TTabItem; + TabItem2: TTabItem; + TabItem3: TTabItem; + GroupBox9: TGroupBox; + Layout11: TLayout; + Edit7: TEdit; + SearchEditButton6: TSearchEditButton; + ComboBox6: TComboBox; + GroupBox10: TGroupBox; + Layout12: TLayout; + Edit8: TEdit; + SearchEditButton7: TSearchEditButton; + ComboBox7: TComboBox; + GroupBox11: TGroupBox; + Layout13: TLayout; + Edit9: TEdit; + SearchEditButton8: TSearchEditButton; + ComboBox8: TComboBox; + GroupBox12: TGroupBox; + Layout14: TLayout; + Label9: TLabel; + SpinBox6: TSpinBox; + Label10: TLabel; + SpinBox8: TSpinBox; + VertScrollBox2: TVertScrollBox; + TabControl2: TTabControl; + TabItem4: TTabItem; + TabItem5: TTabItem; + TabItem6: TTabItem; + TabItem7: TTabItem; + TabItem8: TTabItem; + GroupBox13: TGroupBox; + Layout15: TLayout; + GroupBox14: TGroupBox; + Layout16: TLayout; + Edit11: TEdit; + SearchEditButton10: TSearchEditButton; + Memo1: TMemo; + Layout17: TLayout; + Button3: TButton; + Button4: TButton; + OpenDialog2: TOpenDialog; + Label11: TLabel; + Layout4: TLayout; + Button1: TButton; Label5: TLabel; Edit6: TEdit; SearchEditButton5: TSearchEditButton; + Layout18: TLayout; + Button5: TButton; + Layout19: TLayout; + Button6: TButton; + VertScrollBox3: TVertScrollBox; + TabItem9: TTabItem; + VertScrollBox4: TVertScrollBox; + GroupBox15: TGroupBox; + Layout20: TLayout; + Edit10: TEdit; + SearchEditButton9: TSearchEditButton; + ComboBox9: TComboBox; + GroupBox16: TGroupBox; + Layout21: TLayout; + Edit12: TEdit; + SearchEditButton11: TSearchEditButton; + ComboBox10: TComboBox; + GroupBox17: TGroupBox; + Layout22: TLayout; + Label12: TLabel; + SpinBox9: TSpinBox; + Label13: TLabel; + SpinBox10: TSpinBox; + GroupBox18: TGroupBox; + Layout23: TLayout; + Edit13: TEdit; + SearchEditButton12: TSearchEditButton; + ComboBox11: TComboBox; + Layout24: TLayout; + Button7: TButton; + VertScrollBox5: TVertScrollBox; + GroupBox19: TGroupBox; + Layout25: TLayout; + Edit14: TEdit; + SearchEditButton13: TSearchEditButton; + ComboBox12: TComboBox; + GroupBox20: TGroupBox; + Layout26: TLayout; + Edit15: TEdit; + SearchEditButton14: TSearchEditButton; + ComboBox13: TComboBox; + GroupBox21: TGroupBox; + Layout27: TLayout; + Label14: TLabel; + SpinBox11: TSpinBox; + Label15: TLabel; + SpinBox12: TSpinBox; + GroupBox22: TGroupBox; + Layout28: TLayout; + Edit16: TEdit; + SearchEditButton15: TSearchEditButton; + ComboBox14: TComboBox; + Layout29: TLayout; + Button8: TButton; + GroupBox23: TGroupBox; + Layout30: TLayout; + Edit17: TEdit; + SearchEditButton16: TSearchEditButton; + ComboBox15: TComboBox; + VertScrollBox6: TVertScrollBox; + GroupBox24: TGroupBox; + Layout31: TLayout; + Edit18: TEdit; + SearchEditButton17: TSearchEditButton; + ComboBox16: TComboBox; + GroupBox25: TGroupBox; + Layout32: TLayout; + Edit19: TEdit; + SearchEditButton18: TSearchEditButton; + GroupBox26: TGroupBox; + Layout33: TLayout; + Label17: TLabel; + SpinBox14: TSpinBox; + GroupBox27: TGroupBox; + Layout34: TLayout; + Edit20: TEdit; + SearchEditButton19: TSearchEditButton; + Layout35: TLayout; + Button9: TButton; + VertScrollBox7: TVertScrollBox; + GroupBox28: TGroupBox; + Layout36: TLayout; + Edit21: TEdit; + SearchEditButton20: TSearchEditButton; + ComboBox19: TComboBox; + GroupBox29: TGroupBox; + Layout37: TLayout; + Edit22: TEdit; + SearchEditButton21: TSearchEditButton; + GroupBox30: TGroupBox; + Layout38: TLayout; + Label18: TLabel; + SpinBox15: TSpinBox; + Label19: TLabel; + SpinBox16: TSpinBox; + GroupBox31: TGroupBox; + Layout39: TLayout; + Edit23: TEdit; + SearchEditButton22: TSearchEditButton; + ComboBox21: TComboBox; + GroupBox32: TGroupBox; + Layout40: TLayout; + Edit24: TEdit; + Layout41: TLayout; + Button10: TButton; + SaveDialog2: TSaveDialog; + VertScrollBox8: TVertScrollBox; + GroupBox33: TGroupBox; + Layout42: TLayout; + Edit25: TEdit; + SearchEditButton23: TSearchEditButton; + GroupBox34: TGroupBox; + Layout43: TLayout; + Edit26: TEdit; + SearchEditButton24: TSearchEditButton; + GroupBox35: TGroupBox; + Layout44: TLayout; + Label16: TLabel; + SpinBox13: TSpinBox; + GroupBox36: TGroupBox; + Layout45: TLayout; + Edit27: TEdit; + SearchEditButton25: TSearchEditButton; + Layout46: TLayout; + Button11: TButton; + ComboBox17: TComboBox; + ComboBox18: TComboBox; + CheckBox7: TCheckBox; + Label20: TLabel; + Edit28: TEdit; + SearchEditButton26: TSearchEditButton; + Label21: TLabel; + ComboEdit2: TComboEdit; + CheckBox1: TCheckBox; + Label3: TLabel; + SpinBox3: TSpinBox; + CheckBox6: TCheckBox; procedure FormShow(Sender: TObject); procedure SearchEditButton1Click(Sender: TObject); procedure SearchEditButton3Click(Sender: TObject); @@ -77,13 +249,57 @@ type procedure Button2Click(Sender: TObject); procedure ComboBox2Change(Sender: TObject); procedure Button1Click(Sender: TObject); - procedure ComboBox1Change(Sender: TObject); - procedure SearchEditButton2Click(Sender: TObject); procedure ComboBox4Change(Sender: TObject); procedure SearchEditButton4Click(Sender: TObject); procedure Edit6Change(Sender: TObject); procedure SearchEditButton5Click(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); + procedure ComboBox5Change(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure SearchEditButton10Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure ComboBox7Change(Sender: TObject); + procedure ComboBox6Change(Sender: TObject); + procedure ComboBox8Change(Sender: TObject); + procedure SearchEditButton7Click(Sender: TObject); + procedure SearchEditButton6Click(Sender: TObject); + procedure SearchEditButton8Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure ComboBox9Change(Sender: TObject); + procedure ComboBox11Change(Sender: TObject); + procedure ComboBox10Change(Sender: TObject); + procedure SearchEditButton21Click(Sender: TObject); + procedure ComboBox19Change(Sender: TObject); + procedure ComboBox21Change(Sender: TObject); + procedure ComboBox12Change(Sender: TObject); + procedure ComboBox15Change(Sender: TObject); + procedure ComboBox14Change(Sender: TObject); + procedure ComboBox13Change(Sender: TObject); + procedure SearchEditButton20Click(Sender: TObject); + procedure SearchEditButton22Click(Sender: TObject); + procedure SearchEditButton9Click(Sender: TObject); + procedure SearchEditButton12Click(Sender: TObject); + procedure SearchEditButton11Click(Sender: TObject); + procedure SearchEditButton13Click(Sender: TObject); + procedure SearchEditButton16Click(Sender: TObject); + procedure SearchEditButton15Click(Sender: TObject); + procedure SearchEditButton14Click(Sender: TObject); + procedure ComboBox16Change(Sender: TObject); + procedure SearchEditButton17Click(Sender: TObject); + procedure SearchEditButton19Click(Sender: TObject); + procedure SearchEditButton18Click(Sender: TObject); + procedure Button6Click(Sender: TObject); + procedure Button10Click(Sender: TObject); + procedure Button7Click(Sender: TObject); + procedure Button8Click(Sender: TObject); + procedure Button9Click(Sender: TObject); + procedure SearchEditButton23Click(Sender: TObject); + procedure Button11Click(Sender: TObject); + procedure ComboBox18Change(Sender: TObject); + procedure ComboBox17Change(Sender: TObject); + procedure SearchEditButton25Click(Sender: TObject); + procedure SearchEditButton24Click(Sender: TObject); + procedure CheckBox4Change(Sender: TObject); private { Private declarations } public @@ -93,6 +309,8 @@ type var Form1: TForm1; CmdStr: TArray; + Init: Boolean = False; + DecodeMode: Integer = -1; function GetModuleName: string; function GetIniString(Section, Key, Default, FileName: string): string; @@ -140,7 +358,38 @@ begin end; end; +procedure TForm1.Button10Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('generate', CmdStr, Length(CmdStr)); + Insert('-c' + SpinBox15.Text + 'mb', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox16.Text, CmdStr, Length(CmdStr)); + Insert('-m' + Edit24.Text, CmdStr, Length(CmdStr)); + Insert(Edit21.Text, CmdStr, Length(CmdStr)); + Insert(Edit23.Text, CmdStr, Length(CmdStr)); + Insert(Edit22.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.Button11Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('decode', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox13.Text, CmdStr, Length(CmdStr)); + if CheckBox7.IsChecked then + Insert('-v', CmdStr, Length(CmdStr)); + Insert('--basedir=' + Edit6.Text, CmdStr, Length(CmdStr)); + Insert(Edit25.Text, CmdStr, Length(CmdStr)); + case DecodeMode of + 0: + Insert(Edit26.Text, CmdStr, Length(CmdStr)); + end; +end; + procedure TForm1.Button1Click(Sender: TObject); +var + S: String; begin SetLength(CmdStr, 0); Insert(ParamStr(0), CmdStr, Length(CmdStr)); @@ -155,19 +404,21 @@ begin if CheckBox6.IsChecked then Insert('-v', CmdStr, Length(CmdStr)); Insert('-m' + Edit2.Text, CmdStr, Length(CmdStr)); - if ComboBox1.ItemIndex = 1 then - Insert('-db', CmdStr, Length(CmdStr)) - else if ComboBox1.ItemIndex > 1 then - Insert('-db' + Edit4.Text, CmdStr, Length(CmdStr)); - if CheckBox3.IsChecked then + if ComboBox5.ItemIndex > 0 then Insert('-dd' + IfThen(SpinBox4.Enabled, SpinBox4.Text, ''), CmdStr, Length(CmdStr)); + if ComboEdit1.Enabled then + Insert('-SI' + ComboEdit1.Text, CmdStr, Length(CmdStr)); if CheckBox4.IsChecked then - Insert('--compress=' + 't' + SpinBox2.Text + ':l' + SpinBox7.Text + ':hi' + - IfThen(CheckBox5.IsChecked, '1', '0'), CmdStr, Length(CmdStr)); - Insert('--basedir=' + Edit6.Text, CmdStr, Length(CmdStr)); + begin + S := ''; + if not ComboEdit2.Text.StartsWith('Auto', False) then + S := ':d' + ReplaceText(ComboEdit2.Text, ' ', ''); + Insert('-l' + SpinBox7.Text + S, CmdStr, Length(CmdStr)); + end; + Insert('-bd' + Edit6.Text, CmdStr, Length(CmdStr)); Insert(Edit1.Text, CmdStr, Length(CmdStr)); - if ComboBox3.ItemIndex = 0 then + if ComboBox3.ItemIndex = 1 then Insert(Edit3.Text, CmdStr, Length(CmdStr)); end; @@ -179,10 +430,144 @@ begin Form2.Close; end; -procedure TForm1.ComboBox1Change(Sender: TObject); +procedure TForm1.Button3Click(Sender: TObject); begin - Edit4.Enabled := ComboBox1.ItemIndex in [2, 3]; - Edit4.Text := ''; + OpenDialog2.FileName := ''; + if OpenDialog2.Execute then + Memo1.Lines.AddStrings(OpenDialog2.Files); +end; + +procedure TForm1.Button4Click(Sender: TObject); +var + Dir: string; +begin + if SelectDirectory('', '', Dir) then + Memo1.Lines.Add(Dir); +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('find', CmdStr, Length(CmdStr)); + Insert('-c' + SpinBox6.Text + 'mb', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox8.Text, CmdStr, Length(CmdStr)); + Insert(Edit8.Text, CmdStr, Length(CmdStr)); + Insert(Edit7.Text, CmdStr, Length(CmdStr)); + if ComboBox8.ItemIndex = 1 then + Insert(Edit9.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.Button6Click(Sender: TObject); +var + I: Integer; +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('archive', CmdStr, Length(CmdStr)); + for I := 0 to Memo1.Lines.Count - 1 do + Insert(Memo1.Lines[I], CmdStr, Length(CmdStr)); + Insert(Edit11.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.Button7Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('erase', CmdStr, Length(CmdStr)); + Insert('-c' + SpinBox9.Text + 'mb', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox10.Text, CmdStr, Length(CmdStr)); + Insert(Edit10.Text, CmdStr, Length(CmdStr)); + Insert(Edit13.Text, CmdStr, Length(CmdStr)); + if ComboBox10.ItemIndex = 1 then + Insert(Edit12.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.Button8Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('replace', CmdStr, Length(CmdStr)); + Insert('-c' + SpinBox11.Text + 'mb', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox12.Text, CmdStr, Length(CmdStr)); + Insert(Edit14.Text, CmdStr, Length(CmdStr)); + Insert(Edit17.Text, CmdStr, Length(CmdStr)); + Insert(Edit16.Text, CmdStr, Length(CmdStr)); + if ComboBox13.ItemIndex = 1 then + Insert(Edit15.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.Button9Click(Sender: TObject); +begin + SetLength(CmdStr, 0); + Insert(ParamStr(0), CmdStr, Length(CmdStr)); + Insert('patch', CmdStr, Length(CmdStr)); + Insert('-t' + SpinBox14.Text, CmdStr, Length(CmdStr)); + Insert(Edit18.Text, CmdStr, Length(CmdStr)); + Insert(Edit20.Text, CmdStr, Length(CmdStr)); + Insert(Edit19.Text, CmdStr, Length(CmdStr)); +end; + +procedure TForm1.CheckBox4Change(Sender: TObject); +begin + SpinBox7.Enabled := CheckBox4.IsChecked; + ComboEdit2.Enabled := CheckBox4.IsChecked; +end; + +procedure TForm1.ComboBox10Change(Sender: TObject); +begin + Edit12.Enabled := ComboBox10.ItemIndex <> 0; +end; + +procedure TForm1.ComboBox11Change(Sender: TObject); +begin + Edit13.Text := ''; +end; + +procedure TForm1.ComboBox12Change(Sender: TObject); +begin + Edit14.Text := ''; +end; + +procedure TForm1.ComboBox13Change(Sender: TObject); +begin + Edit15.Enabled := ComboBox13.ItemIndex <> 0; +end; + +procedure TForm1.ComboBox14Change(Sender: TObject); +begin + Edit16.Text := ''; +end; + +procedure TForm1.ComboBox15Change(Sender: TObject); +begin + Edit17.Text := ''; +end; + +procedure TForm1.ComboBox16Change(Sender: TObject); +begin + Edit18.Text := ''; + Edit20.Text := ''; +end; + +procedure TForm1.ComboBox17Change(Sender: TObject); +begin + Edit27.Text := ''; +end; + +procedure TForm1.ComboBox18Change(Sender: TObject); +begin + Edit26.Text := ''; +end; + +procedure TForm1.ComboBox19Change(Sender: TObject); +begin + Edit21.Text := ''; +end; + +procedure TForm1.ComboBox21Change(Sender: TObject); +begin + Edit23.Text := ''; end; procedure TForm1.ComboBox2Change(Sender: TObject); @@ -197,7 +582,8 @@ end; procedure TForm1.ComboBox3Change(Sender: TObject); begin - Edit3.Enabled := ComboBox3.ItemIndex <> 1; + Edit3.Enabled := ComboBox3.ItemIndex <> 0; + ComboEdit1.Enabled := (ComboBox5.ItemIndex = 2) and (ComboBox3.ItemIndex = 0); end; procedure TForm1.ComboBox4Change(Sender: TObject); @@ -206,9 +592,41 @@ begin Edit5.Text := ''; end; +procedure TForm1.ComboBox5Change(Sender: TObject); +begin + SpinBox4.Enabled := ComboBox5.ItemIndex = 2; + ComboEdit1.Enabled := (ComboBox5.ItemIndex = 2) and (ComboBox3.ItemIndex = 0); +end; + +procedure TForm1.ComboBox6Change(Sender: TObject); +begin + Edit7.Text := ''; +end; + +procedure TForm1.ComboBox7Change(Sender: TObject); +begin + Edit8.Text := ''; +end; + +procedure TForm1.ComboBox8Change(Sender: TObject); +begin + Edit9.Enabled := ComboBox8.ItemIndex <> 0; +end; + +procedure TForm1.ComboBox9Change(Sender: TObject); +begin + Edit10.Text := ''; +end; + procedure TForm1.Edit6Change(Sender: TObject); begin - ShowMessage('Restart required to reload new plugins folder.'); + if Sender = Edit6 then + begin + Edit28.Text := Edit6.Text; + ShowMessage('Restart required to reload new plugins folder.'); + end + else + Edit6.Text := Edit28.Text; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); @@ -223,11 +641,161 @@ procedure TForm1.FormShow(Sender: TObject); var I: Integer; begin - for I := 0 to ComponentCount - 1 do - if Components[I] is TSpinBox then - TSpinBox(Components[I]).Cursor := crDefault; - SpinBox2.Max := CPUCount * 2; - SpinBox2.Value := Max(1, CPUCount div 2); + if not Init then + begin + Init := True; + for I := 0 to ComponentCount - 1 do + begin + if Components[I] is TSpinBox then + TSpinBox(Components[I]).Cursor := crDefault; + if Components[I] is TComboBox then + TComboBox(Components[I]).OnChange(nil); + end; + SpinBox2.Max := CPUCount * 2; + SpinBox2.Value := Max(1, CPUCount div 2); + SpinBox8.Max := CPUCount * 2; + SpinBox8.Value := Max(1, CPUCount div 2); + SpinBox10.Max := CPUCount * 2; + SpinBox10.Value := Max(1, CPUCount div 2); + SpinBox12.Max := CPUCount * 2; + SpinBox12.Value := Max(1, CPUCount div 2); + SpinBox14.Max := CPUCount * 2; + SpinBox14.Value := Max(1, CPUCount div 2); + SpinBox16.Max := CPUCount * 2; + SpinBox16.Value := Max(1, CPUCount div 2); + SpinBox13.Max := CPUCount * 2; + SpinBox13.Value := Max(1, CPUCount div 2); + end; +end; + +procedure TForm1.SearchEditButton10Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit11.Text := SaveDialog1.FileName; +end; + +procedure TForm1.SearchEditButton11Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit12.Text := SaveDialog1.FileName; +end; + +procedure TForm1.SearchEditButton12Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox11.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit13.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit13.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton13Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox12.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit14.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit14.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton14Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit15.Text := SaveDialog1.FileName; +end; + +procedure TForm1.SearchEditButton15Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox14.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit16.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit16.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton16Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox15.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit17.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit17.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton17Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox16.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit18.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit18.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton18Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit19.Text := SaveDialog1.FileName; +end; + +procedure TForm1.SearchEditButton19Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox16.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit20.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit20.Text := Dir; + end; end; procedure TForm1.SearchEditButton1Click(Sender: TObject); @@ -247,19 +815,121 @@ begin end; end; -procedure TForm1.SearchEditButton2Click(Sender: TObject); +procedure TForm1.SearchEditButton20Click(Sender: TObject); +var + Dir: string; begin - if ComboBox1.ItemIndex = 2 then + case ComboBox19.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit21.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit21.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton21Click(Sender: TObject); +begin + SaveDialog2.FileName := ''; + if SaveDialog2.Execute then + Edit22.Text := SaveDialog2.FileName; +end; + +procedure TForm1.SearchEditButton22Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox21.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit23.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit23.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton23Click(Sender: TObject); + function IndexInt(AInteger: Integer; const AValues: array of Integer) + : Integer; + var + I: Integer; begin - SaveDialog1.FileName := ''; - if SaveDialog1.Execute then - Edit4.Text := SaveDialog1.FileName; - end - else if ComboBox1.ItemIndex = 3 then + Result := -1; + for I := Low(AValues) to High(AValues) do + if AInteger = AValues[I] then + begin + Result := I; + break; + end; + end; + +const + XTOOL_PRECOMP = $304C5458; + XTOOL_IODEC = $314C5458; + XTOOL_PATCH = $324C5458; + XTOOL_ARCH = $334C5458; + XTOOL_EXEC = $344C5458; +var + I: Integer; +begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then begin - OpenDialog1.FileName := ''; - if OpenDialog1.Execute then - Edit4.Text := OpenDialog1.FileName; + with TFileStream.Create(OpenDialog1.FileName, fmShareDenyNone) do + try + ReadBuffer(I, I.Size); + finally + Free; + end; + DecodeMode := IndexInt(I, [XTOOL_PRECOMP, XTOOL_IODEC, XTOOL_PATCH, + XTOOL_ARCH]); + if DecodeMode < 0 then + raise Exception.Create('Unsupported input'); + SpinBox13.Enabled := DecodeMode in [0]; + GroupBox36.Enabled := DecodeMode in [1, 2]; + Edit25.Text := OpenDialog1.FileName; + end; +end; + +procedure TForm1.SearchEditButton24Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox18.ItemIndex of + 0: + begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit26.Text := SaveDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit26.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton25Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox17.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit27.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit27.Text := Dir; end; end; @@ -283,7 +953,68 @@ var Dir: string; begin if SelectDirectory('', '', Dir) then + begin Edit6.Text := Dir; + Edit28.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton6Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox6.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit7.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit7.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton7Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox7.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit8.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit8.Text := Dir; + end; +end; + +procedure TForm1.SearchEditButton8Click(Sender: TObject); +begin + SaveDialog1.FileName := ''; + if SaveDialog1.Execute then + Edit9.Text := SaveDialog1.FileName; +end; + +procedure TForm1.SearchEditButton9Click(Sender: TObject); +var + Dir: string; +begin + case ComboBox9.ItemIndex of + 0: + begin + OpenDialog1.FileName := ''; + if OpenDialog1.Execute then + Edit10.Text := OpenDialog1.FileName; + end; + 1: + if SelectDirectory('', '', Dir) then + Edit10.Text := Dir; + end; end; end. diff --git a/changes.txt b/changes.txt index ec4bced..1b3101b 100644 --- a/changes.txt +++ b/changes.txt @@ -1,3 +1,28 @@ + ES_R45 (0.7.0) + - added ability to redirect base directory for plugins and libraries + - added restrictions to avoid errors with experimental codecs + - added optimize option to speed up the decoding process for zstd and oodle codecs + - added dictionary parameter for fast-lzma2 + - added memory caching when decoding to alleviate speed bottleneck + - fixed bug with download feature for inputs in URL format + - fixed issues with exporting precompression database + - fixed issues with executable plugin support + - fixed issues advanced configuration based plugin support + - fixed potential decoding issue upon using plugin support functions + - fixed issues with deduplication feature + - fixed issues with jojpeg codec + - replaced crc32c with xxh3_128 to reduce collisions when using the database and deduplication feature + - replaced memory manager with FastMM4-AVX to improve scaling in multi threaded scenarios + - improved user interface + - improved oodle codec performance for 2.6.0+ libraries + - improved encoding speed when using internal codecs + - improved processing speed when depth is used + - removed fast lzma2 multi threaded decompression due to excessive memory requirements + - removed debugging information when using the patch function + - removed ability to toggle database feature and ability to export database files (now enabled by default) + - updated deduplication virtual memory allocation + - updated reflate codec to verify streams prone to data corruption + ES_R44 (0.6.9) - added library checker (trial and error) - improved user interface diff --git a/common/Utils.pas b/common/Utils.pas index 2369c35..0b35db1 100644 --- a/common/Utils.pas +++ b/common/Utils.pas @@ -126,8 +126,8 @@ type FIndex, FCount: Integer; procedure FSetPos(APosition: Int64); procedure FSetSize(ASize: Int64); - procedure FUpdate1; - procedure FUpdate2; + procedure FUpdateRead; + procedure FUpdateWrite; public constructor Create; destructor Destroy; override; @@ -138,6 +138,7 @@ type function Add(AStreamType: Pointer; MaxSize: Int64 = FMaxStreamSize) : Integer; procedure Update(Index: Integer; MaxSize: Int64); + function MaxSize(Index: Integer): NativeInt; end; TMemoryStreamEx = class(TMemoryStream) @@ -207,7 +208,7 @@ type procedure Flush(AForceFlush: Boolean = False); public constructor Create(const AMapName: String; AFileName: string); overload; - constructor Create(const AMapName: String; ASize: NativeInt); overload; + constructor Create(const AMapName: String; ASize: NativeInt = 0); overload; destructor Destroy; override; procedure SetSize(const NewSize: Int64); override; function Write(const Buffer; Count: LongInt): LongInt; override; @@ -252,17 +253,20 @@ type TProcessStream = class(TStream) private - FInput, FOutput: TStream; - FTask: TTask; + FInput, FOutput, FError: TStream; + FTask, FTask2: TTask; FProcessInfo: TProcessInformation; FStdinr, FStdinw: THandle; FStdoutr, FStdoutw: THandle; + FStderrr, FStderrw: THandle; FExecutable, FCommandLine, FWorkDir: String; + FInSize, FOutSize: Int64; procedure ExecReadTask; procedure ExecWriteTask; + procedure ExecErrorTask; public constructor Create(AExecutable, ACommandLine, AWorkDir: String; - AInput: TStream = nil; AOutput: TStream = nil); + AInput: TStream = nil; AOutput: TStream = nil; AError: TStream = nil); destructor Destroy; override; function Read(var Buffer; Count: LongInt): LongInt; override; function Write(const Buffer; Count: LongInt): LongInt; override; @@ -270,6 +274,23 @@ type procedure Wait; function Done: Boolean; function Running: Boolean; + property InSize: Int64 read FInSize; + property OutSize: Int64 read FOutSize; + end; + + TCacheStream = class(TStream) + private + FStream: TStream; + FTask: TTask; + FMemory: PByte; + FPosition1, FPosition2: Int64; + FAvaiSize, FMaxSize: Integer; + FDone: Boolean; + procedure CacheMemory; + public + constructor Create(Stream: TStream; Size: Integer = 16 * 1024 * 1024); + destructor Destroy; override; + function Read(var Buffer; Count: Integer): Integer; override; end; TDataStore = class(TObject) @@ -778,54 +799,43 @@ procedure TArrayStream.FSetPos(APosition: Int64); var I: Integer; LPosition, LSize: Int64; - IdxSet: Boolean; + B: Boolean; begin FIndex := 0; + LPosition := 0; LSize := 0; - IdxSet := False; + B := False; for I := 0 to FCount - 1 do begin - if APosition > LSize + FStreams[I].Size then - LPosition := FStreams[I].Size - else + FStreams[I].Position := Min(FStreams[I].Size, Max(0, APosition - LSize)); + FStreams[I].Instance.Position := FStreams[I].Position; + if (B = False) and (APosition <= LSize + FStreams[I].Size) then begin - LPosition := Max(0, APosition - LSize); - if not IdxSet then - begin - FIndex := I; - IdxSet := True; - end; + FIndex := I; + B := True; end; - FStreams[I].Instance.Position := LPosition; - FStreams[I].Position := LPosition; - if IdxSet then - break; + Inc(LPosition, FStreams[I].Position); Inc(LSize, FStreams[I].Size); end; - FPosition := APosition; + FPosition := LPosition; end; procedure TArrayStream.FSetSize(ASize: Int64); var I: Integer; - LSize1, LSize2: Int64; + LSize: Int64; begin - LSize2 := 0; + LSize := 0; for I := 0 to FCount - 1 do begin - if ASize > FStreams[I].MaxSize - LSize2 then - LSize1 := FStreams[I].MaxSize - else - LSize1 := Max(0, ASize - LSize2); - FStreams[I].Instance.Size := LSize1; - FStreams[I].Size := LSize1; - FStreams[I].Position := Min(FStreams[I].Position, FStreams[I].Size); - Inc(LSize2, FStreams[I].Size); + FStreams[I].Size := Min(FStreams[I].MaxSize, Max(0, ASize - LSize)); + FStreams[I].Instance.Size := FStreams[I].Size; + Inc(LSize, FStreams[I].Size); end; - FSize := ASize; + FSize := LSize; end; -procedure TArrayStream.FUpdate1; +procedure TArrayStream.FUpdateRead; begin if FStreams[FIndex].Position = FStreams[FIndex].Size then begin @@ -840,7 +850,7 @@ begin end; end; -procedure TArrayStream.FUpdate2; +procedure TArrayStream.FUpdateWrite; begin if FStreams[FIndex].Position = FStreams[FIndex].MaxSize then begin @@ -880,8 +890,9 @@ begin Result := 0; if FCount = 0 then exit; - FUpdate1; - LCount := Min(FStreams[FIndex].Size - FStreams[FIndex].Position, Count); + FUpdateRead; + LCount := Min(FStreams[FIndex].Size - FStreams[FIndex].Position, + Int64(Count)); Result := FStreams[FIndex].Instance.Read(Buffer, LCount); Inc(FStreams[FIndex].Position, Result); Inc(FPosition, Result); @@ -894,13 +905,14 @@ begin Result := 0; if FCount = 0 then exit; - FUpdate2; - LCount := Min(FStreams[FIndex].MaxSize - FStreams[FIndex].Position, Count); + FUpdateWrite; + LCount := Min(FStreams[FIndex].MaxSize - FStreams[FIndex].Position, + Int64(Count)); Result := FStreams[FIndex].Instance.Write(Buffer, LCount); Inc(FStreams[FIndex].Position, Result); - Inc(FPosition, Result); FStreams[FIndex].Size := Max(FStreams[FIndex].Position, FStreams[FIndex].Size); + Inc(FPosition, Result); FSize := Max(FPosition, FSize); end; @@ -945,10 +957,15 @@ end; procedure TArrayStream.Update(Index: Integer; MaxSize: Int64); begin - if FStreams[Index].Size < FStreams[Index].MaxSize then + if FStreams[Index].Size < MaxSize then FStreams[Index].MaxSize := MaxSize; end; +function TArrayStream.MaxSize(Index: Integer): NativeInt; +begin + Result := FStreams[Index].MaxSize; +end; + constructor TMemoryStreamEx.Create(AOwnMemory: Boolean; const AMemory: Pointer; AMaxSize: NativeInt); begin @@ -1272,7 +1289,7 @@ constructor TSharedMemoryStream.Create(const AMapName: String; if OpenAndUse then Result := fmOpenReadWrite or fmShareDenyNone else - Result := fmCreate; + Result := fmCreate or fmShareDenyNone; end; var @@ -1312,6 +1329,7 @@ constructor TSharedMemoryStream.Create(const AMapName: String; ASize: NativeInt); var LSize: Int64; + LMBI: TMemoryBasicInformation; begin inherited Create(False); FStream := nil; @@ -1329,7 +1347,14 @@ begin raise EFOpenError.CreateResFmt(@SFCreateErrorEx, [FMapName, SysErrorMessage(GetLastError)]); FMapBuffer := MapViewOfFile(FMapHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0); + if LSize = 0 then + begin + FillChar(LMBI, sizeof(LMBI), 0); + VirtualQueryEx(GetCurrentProcess, FMapBuffer, LMBI, sizeof(LMBI)); + LSize := LMBI.RegionSize; + end; Update(FMapBuffer, LSize); + SetSize(LSize); end; destructor TSharedMemoryStream.Destroy; @@ -1619,15 +1644,19 @@ begin end; constructor TProcessStream.Create(AExecutable, ACommandLine, AWorkDir: String; - AInput: TStream; AOutput: TStream); + AInput: TStream; AOutput: TStream; AError: TStream); begin inherited Create; FInput := AInput; FOutput := AOutput; + FError := AError; FExecutable := AExecutable; FCommandLine := ACommandLine; FWorkDir := AWorkDir; + FInSize := 0; + FOutSize := 0; FTask := TTask.Create; + FTask2 := TTask.Create; end; destructor TProcessStream.Destroy; @@ -1636,8 +1665,11 @@ begin CloseHandleEx(FStdinw); CloseHandleEx(FStdoutr); CloseHandleEx(FStdoutw); + CloseHandleEx(FStderrr); + CloseHandleEx(FStderrw); CloseHandleEx(FProcessInfo.hProcess); FTask.Free; + FTask2.Free; inherited Destroy; end; @@ -1650,6 +1682,7 @@ begin raise EReadError.CreateRes(@SReadError); if ReadFile(FStdoutr, Buffer, Count, BytesRead, nil) then Result := BytesRead; + Inc(FOutSize, Result); end; function TProcessStream.Write(const Buffer; Count: LongInt): LongInt; @@ -1660,8 +1693,11 @@ begin Result := 0; if Assigned(FInput) then raise EWriteError.CreateRes(@SWriteError); - if WriteFile(FStdinw, Buffer, Count, BytesWritten, nil) then + if Count = 0 then + CloseHandleEx(FStdinw) + else if WriteFile(FStdinw, Buffer, Count, BytesWritten, nil) then Result := BytesWritten; + Inc(FInSize, Result); end; procedure TProcessStream.ExecReadTask; @@ -1673,7 +1709,10 @@ var begin while ReadFile(FStdoutr, Buffer[0], Length(Buffer), BytesRead, nil) and (BytesRead > 0) do + begin + Inc(FOutSize, BytesRead); FOutput.WriteBuffer(Buffer[0], BytesRead); + end; CloseHandleEx(FStdoutr); end; @@ -1687,10 +1726,27 @@ begin BytesWritten := FInput.Read(Buffer[0], BufferSize); while WriteFile(FStdinw, Buffer[0], BytesWritten, BytesWritten, nil) and (BytesWritten > 0) do + begin + Inc(FInSize, BytesWritten); BytesWritten := FInput.Read(Buffer[0], BufferSize); + end; CloseHandleEx(FStdinw); end; +procedure TProcessStream.ExecErrorTask; +const + BufferSize = 65536; +var + Buffer: array [0 .. BufferSize - 1] of Byte; + BytesRead: DWORD; +begin + while ReadFile(FStderrr, Buffer[0], Length(Buffer), BytesRead, nil) and + (BytesRead > 0) do + if Assigned(FError) then + FError.WriteBuffer(Buffer[0], BytesRead); + CloseHandleEx(FStderrr); +end; + function TProcessStream.Execute: Boolean; const PipeSecurityAttributes: TSecurityAttributes = @@ -1699,32 +1755,35 @@ var StartupInfo: TStartupInfo; dwExitCode: DWORD; LWorkDir: PChar; - LStream: THandleStream; begin Result := False; CreatePipe(FStdinr, FStdinw, @PipeSecurityAttributes, 0); CreatePipe(FStdoutr, FStdoutw, @PipeSecurityAttributes, 0); + CreatePipe(FStderrr, FStderrw, @PipeSecurityAttributes, 0); SetHandleInformation(FStdinw, HANDLE_FLAG_INHERIT, 0); SetHandleInformation(FStdoutr, HANDLE_FLAG_INHERIT, 0); + SetHandleInformation(FStderrr, HANDLE_FLAG_INHERIT, 0); ZeroMemory(@StartupInfo, sizeof(StartupInfo)); StartupInfo.cb := sizeof(StartupInfo); StartupInfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := SW_HIDE; StartupInfo.hStdInput := FStdinr; StartupInfo.hStdOutput := FStdoutw; - StartupInfo.hStdError := 0; + StartupInfo.hStdError := FStderrw; ZeroMemory(@FProcessInfo, sizeof(FProcessInfo)); if FWorkDir <> '' then LWorkDir := Pointer(FWorkDir) else LWorkDir := Pointer(GetCurrentDir); if CreateProcess(nil, PChar('"' + FExecutable + '" ' + FCommandLine), nil, - nil, True, NORMAL_PRIORITY_CLASS, nil, LWorkDir, StartupInfo, FProcessInfo) - then + nil, True, 0, nil, LWorkDir, StartupInfo, FProcessInfo) then begin CloseHandleEx(FProcessInfo.hThread); CloseHandleEx(FStdinr); CloseHandleEx(FStdoutw); + CloseHandleEx(FStderrw); + FTask2.Perform(ExecErrorTask); + FTask2.Start; if Assigned(FOutput) and not Assigned(FInput) then begin FTask.Perform(ExecReadTask); @@ -1741,14 +1800,8 @@ begin begin FTask.Perform(ExecReadTask); FTask.Start; - LStream := THandleStream.Create(FStdinw); - try - CopyStream(FInput, LStream); - finally - LStream.Free; - CloseHandleEx(FStdinw); - FTask.Wait; - end; + ExecWriteTask; + FTask.Wait; WaitForSingleObject(FProcessInfo.hProcess, INFINITE); GetExitCodeProcess(FProcessInfo.hProcess, dwExitCode); CloseHandleEx(FProcessInfo.hProcess); @@ -1763,6 +1816,8 @@ begin CloseHandleEx(FStdinw); CloseHandleEx(FStdoutr); CloseHandleEx(FStdoutw); + CloseHandleEx(FStderrr); + CloseHandleEx(FStderrw); RaiseLastOSError; end; end; @@ -1779,7 +1834,9 @@ begin Result := False; CloseHandleEx(FStdinw); CloseHandleEx(FStdoutr); + CloseHandleEx(FStderrr); FTask.Wait; + FTask2.Wait; WaitForSingleObject(FProcessInfo.hProcess, INFINITE); GetExitCodeProcess(FProcessInfo.hProcess, dwExitCode); CloseHandleEx(FProcessInfo.hProcess); @@ -1793,6 +1850,75 @@ begin Result := WaitForSingleObject(FProcessInfo.hProcess, 0) = WAIT_TIMEOUT; end; +constructor TCacheStream.Create(Stream: TStream; Size: Integer); +begin + inherited Create; + FStream := Stream; + GetMem(FMemory, Size); + FPosition1 := 0; + FPosition2 := 0; + FAvaiSize := 0; + FMaxSize := Size; + FDone := False; + FTask := TTask.Create; + FTask.Perform(CacheMemory); + FTask.Start; +end; + +destructor TCacheStream.Destroy; +begin + FDone := True; + FTask.Wait; + FTask.Free; + FreeMem(FMemory); + inherited Destroy; +end; + +procedure TCacheStream.CacheMemory; +var + I: Integer; +begin + AtomicExchange(I, FAvaiSize); + I := FStream.Read((FMemory + FPosition1 mod FMaxSize)^, + Min(FMaxSize - I, FMaxSize - (FPosition1 mod FMaxSize))); + while (I > 0) and (FDone = False) do + begin + Inc(FPosition1, I); + I := AtomicIncrement(FAvaiSize, I); + while I = FMaxSize do + begin + Sleep(1); + AtomicExchange(I, FAvaiSize); + if FDone then + exit; + end; + I := FStream.Read((FMemory + FPosition1 mod FMaxSize)^, + Min(FMaxSize - I, FMaxSize - (FPosition1 mod FMaxSize))); + end; + FDone := True; +end; + +function TCacheStream.Read(var Buffer; Count: Integer): Integer; +var + I: Integer; +begin + if Count <= 0 then + exit(0); + AtomicExchange(I, FAvaiSize); + if I = 0 then + while True do + begin + Sleep(1); + AtomicExchange(I, FAvaiSize); + if (I > 0) or ((I = 0) and FDone) then + break; + end; + Result := Min(Count, Min(I, FMaxSize - (FPosition2 mod FMaxSize))); + Move((FMemory + FPosition2 mod FMaxSize)^, Buffer, Result); + Inc(FPosition2, Result); + AtomicDecrement(FAvaiSize, Result); +end; + constructor TDataStore1.Create(AInput: TStream; ADynamic: Boolean; ASlots, ASize: NativeInt; ATempFile: String); var @@ -2354,7 +2480,7 @@ begin Result := Default; J := 0; for I := Low(FArgs) to High(FArgs) do - if FArgs[I].StartsWith(Parameter, True) then + if FArgs[I].StartsWith(Parameter, False) then begin if J >= Index then begin @@ -2374,7 +2500,7 @@ begin Result := Default; J := 0; for I := Low(FArgs) to High(FArgs) do - if FArgs[I].StartsWith(Parameter, True) then + if FArgs[I].StartsWith(Parameter, False) then begin if J >= Index then begin @@ -2397,7 +2523,7 @@ begin Result := Default; J := 0; for I := Low(FArgs) to High(FArgs) do - if FArgs[I].StartsWith(Parameter, True) then + if FArgs[I].StartsWith(Parameter, False) then begin if J >= Index then begin @@ -2420,7 +2546,7 @@ begin Result := Default; J := 0; for I := Low(FArgs) to High(FArgs) do - if FArgs[I].StartsWith(Parameter, True) then + if FArgs[I].StartsWith(Parameter, False) then begin if J >= Index then begin @@ -3169,32 +3295,32 @@ end; function ConvertToBytes(S: string): Int64; begin - if AnsiContainsStr(S, 'kb') then + if ContainsText(S, 'kb') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 2)) * Power(1024, 1)); exit; end; - if AnsiContainsStr(S, 'mb') then + if ContainsText(S, 'mb') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 2)) * Power(1024, 2)); exit; end; - if AnsiContainsStr(S, 'gb') then + if ContainsText(S, 'gb') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 2)) * Power(1024, 3)); exit; end; - if AnsiContainsStr(S, 'k') then + if ContainsText(S, 'k') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 1)) * Power(1024, 1)); exit; end; - if AnsiContainsStr(S, 'm') then + if ContainsText(S, 'm') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 1)) * Power(1024, 2)); exit; end; - if AnsiContainsStr(S, 'g') then + if ContainsText(S, 'g') then begin Result := Round(StrToFloat(Copy(S, 1, Length(S) - 1)) * Power(1024, 3)); exit; @@ -3204,7 +3330,7 @@ end; function ConvertToThreads(S: string): Integer; begin - if AnsiContainsStr(S, 'p') or AnsiContainsStr(S, '%') then + if ContainsText(S, 'p') or ContainsText(S, '%') then begin Result := Round((CPUCount * StrToInt(Copy(S, 1, Length(S) - 1))) / 100); if Result < 1 then @@ -3488,7 +3614,7 @@ begin else LWorkDir := Pointer(GetCurrentDir); if CreateProcess(nil, PChar('"' + Executable + '" ' + CommandLine), nil, nil, - True, NORMAL_PRIORITY_CLASS, nil, LWorkDir, StartupInfo, ProcessInfo) then + True, 0, nil, LWorkDir, StartupInfo, ProcessInfo) then begin CloseHandleEx(ProcessInfo.hThread); CloseHandleEx(hstdinr); @@ -3541,7 +3667,7 @@ begin else LWorkDir := Pointer(GetCurrentDir); if CreateProcess(nil, PChar('"' + Executable + '" ' + CommandLine), nil, nil, - True, NORMAL_PRIORITY_CLASS, nil, LWorkDir, StartupInfo, ProcessInfo) then + True, 0, nil, LWorkDir, StartupInfo, ProcessInfo) then begin CloseHandleEx(ProcessInfo.hThread); CloseHandleEx(hstdoutw); @@ -3599,7 +3725,7 @@ begin else LWorkDir := Pointer(GetCurrentDir); if CreateProcess(nil, PChar('"' + Executable + '" ' + CommandLine), nil, nil, - True, NORMAL_PRIORITY_CLASS, nil, LWorkDir, StartupInfo, ProcessInfo) then + True, 0, nil, LWorkDir, StartupInfo, ProcessInfo) then begin CloseHandleEx(ProcessInfo.hThread); CloseHandleEx(hstdinr); @@ -3676,7 +3802,7 @@ begin else LWorkDir := Pointer(GetCurrentDir); if CreateProcess(nil, PChar('"' + Executable + '" ' + CommandLine), nil, nil, - True, NORMAL_PRIORITY_CLASS, nil, LWorkDir, StartupInfo, ProcessInfo) then + True, 0, nil, LWorkDir, StartupInfo, ProcessInfo) then begin CloseHandleEx(ProcessInfo.hThread); CloseHandleEx(hstdinr); diff --git a/contrib/FastMM4-AVX/.gitignore b/contrib/FastMM4-AVX/.gitignore new file mode 100644 index 0000000..479afc2 --- /dev/null +++ b/contrib/FastMM4-AVX/.gitignore @@ -0,0 +1,58 @@ +# Uncomment these types if you want even more clean repository. But be careful. +# It can make harm to an existing project source. Read explanations below. +# +# Resource files are binaries containing manifest, project icon and version info. +# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. +*.res +# +# Type library file (binary). In old Delphi versions it should be stored. +# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. +#*.tlb +# +# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. +# Uncomment this if you are not using diagrams or use newer Delphi version. +#*.ddp +# +# Visual LiveBindings file. Added in Delphi XE2. +# Uncomment this if you are not using LiveBindings Designer. +#*.vlb +# +# Deployment Manager configuration file for your project. Added in Delphi XE2. +# Uncomment this if it is not mobile development and you do not use remote debug feature. +#*.deployproj +# + +# Delphi compiler-generated binaries (safe to delete) +*.exe +*.dll +*.bpl +*.bpi +*.dcp +*.so +*.apk +*.drc +*.map +*.dres +*.rsm +*.tds +*.dcu +*.lib + +# Delphi autogenerated files (duplicated info) +*.cfg +*Resource.rc + +# Delphi local files (user-specific info) +*.local +*.identcache +*.projdata +*.tvsconfig +*.dsk + +# Delphi history and backups +__history/ +*.~* +*.bak + +# Castalia statistics file +*.stat diff --git a/contrib/FastMM4-AVX/CPP Builder Support/FastMM4BCB.cpp b/contrib/FastMM4-AVX/CPP Builder Support/FastMM4BCB.cpp new file mode 100644 index 0000000..68616cc --- /dev/null +++ b/contrib/FastMM4-AVX/CPP Builder Support/FastMM4BCB.cpp @@ -0,0 +1,2069 @@ +/* + +Fast Memory Manager: BCB support 2.04 + +Description: + FastMM support unit for C++ Builder. Loads FastMM4 on startup of the Borland + C++ Builder application or DLL. + +Usage: + 1) Copy FastMM4BCB.cpp, FastMM4.pas, FastMM4Message.pas, FastMM4Options.inc, + and FastMM_FullDebugMode.lib to your source folder. + 2) Copy FastMM_FullDebugMode.dll to your application's .exe directory (if you + intend to use FullDebugMode). + 3) To your project, add FastMM4Messages.pas first, then FastMM4.pas, then + FastMM4BCB.cpp. On compiling the .pas files, .hpp files are created and + imported by the subsequent files. + 4) Add USEOBJ("FastMM4BCB.cpp") to your project file, BEFORE any other + USEFORM directives. + 5) Under the Project -> Options -> Linker menu uncheck "Use Dynamic RTL" + (sorry, won't work with the RTL DLL). + 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 initial BCB support. + - JiYuan Xie for doing an entire rewrite of this unit to allow leak reporting, + etc. under BCB. + - Remy Lebeau for some bugfixes. + - James Nachbar and Albert Wiersch for improved usage instructions and + bugfixes. + +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). + Version 2.00 (22 April 2008): + - Rewritten by JiYuan Xie to implement leak reporting, etc. (Thank you!) + Version 2.01 (9 December 2008): + - Fixed a compiler error when 'STRICT' is defined + Version 2.02 (24 January 2009): + - JiYuan Xie fixed the BCB compatibility. (Thanks!) + Version 2.03 (03 March 2009): + - Changes for BCB2009 in "TCHAR = wchar_t" mode + Version 2.04 (10 January 2010): + - Fixed a compilation error in BCB6 (Thanks to Remy Lebeau) + +*/ + +//#ifndef _NO_VCL + +#pragma option push +#pragma option -k- -d -vi- -O2 -b- -3 -a8 -pc -RT- -x -xd -r -AT -vG- -vG0- -vG1- -vG2- -vG3- -vGc- -vGt- -vGd- + +#pragma hdrstop +#include "FastMM4Messages.hpp" +#include "FastMM4.hpp" + +//BCB6 support +#include + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef PatchBCBTerminate + +#ifdef FullDebugMode +#ifndef LoadDebugDLLDynamically + +#pragma link "FastMM_FullDebugMode.lib" + +#if defined(RawStackTraces) +__declspec(dllimport) void __fastcall GetRawStackTrace(unsigned * AReturnAddresses, + unsigned AMaxDepth, unsigned ASkipFrames); +#else +__declspec(dllimport) void __fastcall GetFrameBasedStackTrace(unsigned * AReturnAddresses, + unsigned AMaxDepth, unsigned ASkipFrames); +#endif +__declspec(dllimport) void __fastcall LogStackTrace(unsigned * AReturnAddresses, + unsigned AMaxDepth, char *ABuffer); + +#endif +#endif + +#pragma pack(push,1) +typedef struct { + unsigned char JmpInst; //E9 + int Offset; +} TRelativeJmp32, * PRelativeJmp32; + +typedef struct { + unsigned short JmpInst; //FF 25 + void * * DestPtr; +} TIndirectJmp32, * PIndirectJmp32; +#pragma pack(pop) + +//Return true if write OK +bool __fastcall WriteMem(void * Location, void * Data, unsigned int DataSize) +{ + unsigned long OldProtect; + + if (VirtualProtect(Location, DataSize, PAGE_EXECUTE_READWRITE, &OldProtect)) + { + memmove(Location, Data, DataSize); + + FlushInstructionCache(GetCurrentProcess(), Location, sizeof(DataSize)); + VirtualProtect(Location, DataSize, OldProtect, &OldProtect); + + return true; + } + else { + return false; + } +} + +#define RelativeJmp32Inst (0xE9) + +//Return true if patch OK +bool __fastcall PatchProc(void * OldProc, void * NewProc, TRelativeJmp32 * Backup) +{ + if (OldProc && NewProc) + { + TRelativeJmp32 JmpData; + + JmpData.JmpInst = RelativeJmp32Inst; + JmpData.Offset = (int)NewProc - ((int)OldProc + sizeof(JmpData)); + + if (Backup) + { + *Backup = *((PRelativeJmp32)OldProc); + } + + return WriteMem(OldProc, &JmpData, sizeof(JmpData)); + } + else { + return false; + } +}; + +//Return true if unpatch OK +bool __fastcall UnPatchProc(void * OldProc, void * NewProc, TRelativeJmp32 * Backup) +{ + if (OldProc && NewProc && Backup) + { + int Offset = (int)NewProc - ((int)OldProc + sizeof(TRelativeJmp32)); + if ((((PRelativeJmp32)OldProc)->JmpInst == RelativeJmp32Inst) + && (((PRelativeJmp32)OldProc)->Offset == Offset)) + { + return WriteMem(OldProc, &Backup, sizeof(*Backup)); + } + } + + return false; +}; + +typedef void * (__fastcall * GetMemFunc)(int Size); +typedef int (__fastcall * FreeMemFunc)(void * P); +typedef void * (__fastcall * ReallocMemFunc)(void * P, int Size); +#if __BORLANDC__ >= 0x582 +//>= BDS2006 ? +typedef void * (__fastcall * AllocMemFunc)(unsigned Size); +#endif + +#ifndef _RTLDLL //Not using Dynamic RTL +extern void _terminate(int code); +#endif + +#ifndef FullDebugMode + #define InternalGetMem FastGetMem + #define InternalFreeMem FastFreeMem + #define InternalReallocMem FastReallocMem + + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + #define InternalAllocMem FastAllocMem + #endif +#else + #define InternalGetMem DebugGetMem + #define InternalFreeMem DebugFreeMem + #define InternalReallocMem DebugReallocMem + + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + #define InternalAllocMem DebugAllocMem + #endif +#endif //FullDebugMode + + +#ifdef CheckCppObjectTypeEnabled +void __fastcall FinalizeModuleCodeDataRanges(void); +#endif +void __fastcall FinalizeHeapRedirectorStoreList(void); +extern bool IsBorlandMMDLL; +#if defined(__DLL__) && defined(FullDebugMode) && defined(LoadDebugDLLDynamically) +void __fastcall CallOldFullDebugModeDllEntry(void); +#endif + +void * StockGetMemPtr = NULL; + + +void New_terminate(int code) +{ + //FasttMM4.pas need export a "FinalizeMemoryManager" routine which contain + //codes of original "finalization" section + FinalizeMemoryManager(); + + #ifdef CheckCppObjectTypeEnabled + GetCppVirtObjSizeByTypeIdPtrFunc = NULL; + GetCppVirtObjTypeIdPtrFunc = NULL; + GetCppVirtObjTypeNameFunc = NULL; + GetCppVirtObjTypeNameByTypeIdPtrFunc = NULL; + GetCppVirtObjTypeNameByVTablePtrFunc = NULL; + + FinalizeModuleCodeDataRanges(); + #endif + + #ifdef DetectMMOperationsAfterUninstall + //Do nothing + #endif + + if (IsBorlandMMDLL) + { + FinalizeHeapRedirectorStoreList(); + } + + #if defined(__DLL__) && defined(FullDebugMode) && defined(LoadDebugDLLDynamically) + CallOldFullDebugModeDllEntry(); + #endif + + ExitProcess(code); +} + +void * PatchLocation = NULL; + +#if defined(__DLL__) && defined(FullDebugMode) && defined(LoadDebugDLLDynamically) + +#pragma pack(push,1) + +typedef struct { + unsigned char PushEbp; //0x55 + unsigned short MovEbpEsp; //0x8B 0xEC + unsigned char SubEsp[3]; //0x83 0xC4 0xC4 +} DelphiDllEntryInsts, *DelphiDllEntryInstsPtr; + +typedef struct { + DelphiDllEntryInsts OldInsts; + TRelativeJmp32 JmpToRemainInsts; +} FullDebugModeDllEntryThunk; + +#pragma pack(pop) + +FullDebugModeDllEntryThunk OldFullDebugModeDllEntryThunk; +bool ExecuteOldFullDebugModeDllEntry = false; +bool FullDebugModeDllEntryHooked = false; + +bool __fastcall PrepareFullDebugModeDllEntryThunk(FullDebugModeDllEntryThunk *Thunk, + void *OldEntry) +{ + DelphiDllEntryInstsPtr OldInstsPtr = (DelphiDllEntryInstsPtr)OldEntry; + if ((OldInstsPtr->PushEbp == 0x55) + && (OldInstsPtr->MovEbpEsp == 0xEC8B) + && (OldInstsPtr->SubEsp[0] == 0x83) + && (OldInstsPtr->SubEsp[1] == 0xC4)) + { + unsigned long OldProtect; + + if (VirtualProtect((void *)Thunk, sizeof(*Thunk), PAGE_EXECUTE_READWRITE, &OldProtect)) + { + Thunk->OldInsts = *OldInstsPtr; + //jump to (OldEntry + sizeof(*OldInstsPtr)) from Thunk->JmpToRemainInsts + Thunk->JmpToRemainInsts.JmpInst = RelativeJmp32Inst; + Thunk->JmpToRemainInsts.Offset = ((int)OldInstsPtr + sizeof(*OldInstsPtr)) + - ((int)&Thunk->JmpToRemainInsts + sizeof(Thunk->JmpToRemainInsts)); + + return true; + } + } + return false; +} + +#if defined(PURE_CPLUSPLUS) //__BORLANDC__ < 0x0560 + +typedef BOOL WINAPI (*DllEntryFunc)( + HINSTANCE hinstDLL, + DWORD fdwReason, + LPVOID lpvReserved); + +BOOL WINAPI NewFullDebugModeDllEntry( + HINSTANCE hinstDLL, + DWORD fdwReason, + LPVOID lpvReserved) +{ + //[ESP + 4] hinstDLL + //[ESP + 8] fdwReason + //[ESP + 12] lpvReserved + + if (fdwReason != DLL_PROCESS_DETACH) + { + DllEntryFunc OldDllEntry = (DllEntryFunc)(&OldFullDebugModeDllEntryThunk); + return (*OldDllEntry)(hinstDLL, fdwReason, lpvReserved); + } + else + { + if (ExecuteOldFullDebugModeDllEntry) + { + ExecuteOldFullDebugModeDllEntry = 0; + + DllEntryFunc OldDllEntry = (DllEntryFunc)(&OldFullDebugModeDllEntryThunk); + return (*OldDllEntry)(hinstDLL, fdwReason, lpvReserved); + } + else + { + return true; + } + } +} + +#else + +//#pragma warn -8002 //"W8002: Restarting compile using assembly" +#pragma option -w-asc + +//#pragma warn -8070 //"W8070 Function should return a value" +#pragma option -w-rvl //the same as above + +__declspec(naked) BOOL WINAPI NewFullDebugModeDllEntry( + HINSTANCE hinstDLL, + DWORD fdwReason, + LPVOID lpvReserved) +{ + //[ESP + 4] hinstDLL + //[ESP + 8] fdwReason + //[ESP + 12] lpvReserved + +/* + if (fdwReason != DLL_PROCESS_DETACH) + { + DllEntryFunc OldDllEntry = (DllEntryFunc)(&OldFullDebugModeDllEntryThunk); + return (*OldDllEntry)(hinstDLL, fdwReason, lpvReserved); + } + else + { + if (ExecuteOldFullDebugModeDllEntry) + { + ExecuteOldFullDebugModeDllEntry = 0; + + DllEntryFunc OldDllEntry = (DllEntryFunc)(&OldFullDebugModeDllEntryThunk); + return (*OldDllEntry)(hinstDLL, fdwReason, lpvReserved); + } + else + { + return true; + } + } +*/ + asm + { + mov eax, [esp + 8] //fdwReason + test eax, eax //is DLL_PROCESS_DETACH ? + jz ProcessDetech + #if __BORLANDC__ < 0x0560 + lea eax, OldFullDebugModeDllEntryThunk //not DLL_PROCESS_DETACH, call original entry + jmp eax + #else + jmp OldFullDebugModeDllEntryThunk //not DLL_PROCESS_DETACH, call original entry + #endif + + ProcessDetech: + movzx eax, ExecuteOldFullDebugModeDllEntry + test eax, eax + jz Exit //do nothing if ExecuteOldFullDebugModeDllEntry flag not set + xor eax, eax + mov ExecuteOldFullDebugModeDllEntry, al //reset ExecuteOldDebugModeDllEntry flag + + #if __BORLANDC__ < 0x0560 + lea eax, OldFullDebugModeDllEntryThunk + jmp eax + #else + jmp OldFullDebugModeDllEntryThunk + #endif + Exit: + setz al + ret + } +} +#endif + +void * __fastcall GetModuleEntryPoint(HMODULE AModule) +{ + if (AModule) + { + PIMAGE_NT_HEADERS ntheader = (PIMAGE_NT_HEADERS)((unsigned)AModule + + ((PIMAGE_DOS_HEADER)AModule)->e_lfanew); + + return (void *)(ntheader->OptionalHeader.AddressOfEntryPoint + + (unsigned)AModule); + } + else + { + return NULL; + } +} + +bool __fastcall TryHookFullDebugModeDllEntry(void) +{ + HMODULE AModule = GetModuleHandle(FullDebugModeLibraryName); + if (AModule) + { + void *Entry = GetModuleEntryPoint(AModule); + if (Entry) + { + if (PrepareFullDebugModeDllEntryThunk(&OldFullDebugModeDllEntryThunk, Entry)) + { + FullDebugModeDllEntryHooked = PatchProc(Entry, &NewFullDebugModeDllEntry, NULL); + return FullDebugModeDllEntryHooked; + } + } + } + + return false; +} + +void __fastcall CallOldFullDebugModeDllEntry(void) +{ + if (FullDebugModeDllEntryHooked) + { + HMODULE AModule = GetModuleHandle(FullDebugModeLibraryName); + if (AModule) + { + ExecuteOldFullDebugModeDllEntry = 1; + + NewFullDebugModeDllEntry((HINSTANCE)AModule, DLL_PROCESS_DETACH, NULL); + } + } +} +#endif + +#define DVCLALResName _TEXT("DVCLAL") + +#define _terminateExport "_terminate" + +//Return true if patched OK +bool __fastcall Patch_terminate(void) +{ + if (!PatchLocation) + { + #ifndef _RTLDLL //Not uses Dynamic RTL + PatchLocation = &_terminate; + #else + //Get module handle of RTL dll + PIndirectJmp32 P = (PIndirectJmp32)&exit; + if ((!IsBadReadPtr(P, sizeof(TIndirectJmp32))) && (P->JmpInst == 0x25FF) + && (P->DestPtr) && (!IsBadReadPtr(P->DestPtr, sizeof(void *)))) + { + PatchLocation = *(P->DestPtr); + } + else { + PatchLocation = P; + } + + PatchLocation = (void *)System::FindHInstance(PatchLocation); + if (PatchLocation) + { + //Get real patch location + PatchLocation = GetProcAddress((HMODULE)PatchLocation, _terminateExport); + if (!PatchLocation) + { + return false; + } + } + else { + return false; + } + #endif //_RTLDLL + + if ((((PRelativeJmp32)PatchLocation)->JmpInst == RelativeJmp32Inst) + || (!PatchProc(PatchLocation, &New_terminate, NULL))) + { + PatchLocation = NULL; + return false; + } + else { + return true; + } + } + else { + return true; + } +} + +extern int __CPPdebugHook; + +bool IsMMInstalled = false; +bool IsInDLL = false; +bool IsBorlandMMDLL = false; +bool terminatePatched = false; + +#define CPPdebugHookExport "___CPPdebugHook" + + +//#ifndef _RTLDLL + +#if (__BORLANDC__ < 0x0560) || (__BORLANDC__ > 0x0711) +#if defined(PURE_CPLUSPLUS) || defined(__clang__) + +void * _RTLENTRY Cpp_malloc_Stub(size_t size) +{ + if (size) + return InternalGetMem(size); + else + return NULL; +} + +void _RTLENTRY Cpp_free_Stub(void *block) +{ + if (block) + InternalFreeMem(block); +} + +void * _RTLENTRY Cpp_realloc_Stub(void *block, size_t size) +{ + if (!block) + { + if (size) + return InternalGetMem(size); + else + return NULL; + } + else { + if (!size) + { + InternalFreeMem(block); + return NULL; + } + else + return InternalReallocMem(block, size); + } +} + +void _RTLENTRY Cpp_terminate_Stub(void) +{ +} + +#else + +GetMemFunc GetMemPtr; +FreeMemFunc FreeMemPtr; +ReallocMemFunc ReallocMemPtr; + +//#pragma warn -8002 //"W8002: Restarting compile using assembly" +#pragma option -w-asc + +//#pragma warn -8070 //"W8070 Function should return a value" +#pragma option -w-rvl //the same as above + +__declspec(naked) void * _RTLENTRY Cpp_malloc_Stub(size_t size) +{ + asm + { + mov eax, [esp + 4] //size + test eax, eax + jz malloc_Exit + //#if __BORLANDC__ >= 0x564 + // jmp GetMemPtr + // nop + //#else + call GetMemPtr + ret + //#endif + nop + malloc_Exit: + ret + } +} + +__declspec(naked) void _RTLENTRY Cpp_free_Stub(void *block) +{ + asm + { + mov eax, [esp + 4] //block + test eax, eax + jz free_Exit + //#if __BORLANDC__ >= 0x564 + // jmp FreeMemPtr + // nop + //#else + call FreeMemPtr + ret + //#endif + nop + free_Exit: + ret + } +} + +__declspec(naked) void * _RTLENTRY Cpp_realloc_Stub(void *block, size_t size) +{ + asm + { + mov eax, [esp + 4] //block + test eax, eax + jnz realloc_Realloc + realloc_Alloc: + mov eax, [esp + 8] //size + test eax, eax + jz realloc_Exit2 //realloc_Exit1 + //#if __BORLANDC__ >= 0x564 + // jmp GetMemPtr + // nop + //#else + call GetMemPtr + ret + //#endif + nop + ////realloc_Exit1: + // //ret + realloc_Realloc: + mov edx, [esp + 8] //size + test edx, edx + jnz realloc_DoRealloc + call FreeMemPtr + realloc_ReturnNULL: + xor eax, eax + realloc_Exit2: + ret + nop + nop + nop + realloc_DoRealloc: + //#if __BORLANDC__ >= 0x564 + // jmp ReallocMemPtr + // //ret + //#else + call ReallocMemPtr + ret + //#endif + } +} + +__declspec(naked) void _RTLENTRY Cpp_terminate_Stub(void) +{ + //Do nothing + asm ret; +} +#endif + +#else +//#pragma warn -8070 //"W8070 Function should return a value" +#pragma option -w-rvl //the same as above +__declspec(naked) void * _RTLENTRY Cpp_malloc_Stub(size_t size) +{ + //if (size) + //return InternalGetMem(size); + //else + //return NULL; + asm + { + mov eax, [esp + 4] //size + test eax, eax + jz malloc_Exit + #if __BORLANDC__ >= 0x564 + jmp InternalGetMem + nop + #else + call InternalGetMem + ret + #endif + nop + nop + malloc_Exit: + ret + } +} + +__declspec(naked) void _RTLENTRY Cpp_free_Stub(void *block) +{ + //if (block) + //InternalFreeMem(block); + asm + { + mov eax, [esp + 4] //block + test eax, eax + jz free_Exit + #if __BORLANDC__ >= 0x564 + jmp InternalFreeMem + nop + #else + call InternalFreeMem + ret + #endif + nop + nop + free_Exit: + ret + } +} + +__declspec(naked) void * _RTLENTRY Cpp_realloc_Stub(void *block, size_t size) +{ + /* + if (!block) + { + if (size) + return InternalGetMem(size); + else + return NULL; + } + else { + if (!size) + { + InternalFreeMem(block); + return NULL; + } + else + return InternalReallocMem(block, size); + } + */ + asm + { + mov eax, [esp + 4] //block + test eax, eax + jnz realloc_Realloc + realloc_Alloc: + mov eax, [esp + 8] //size + test eax, eax + jz realloc_Exit2 //realloc_Exit1 + #if __BORLANDC__ >= 0x564 + jmp InternalGetMem + nop + #else + call InternalGetMem + ret + #endif + nop + nop + //realloc_Exit1: + //ret + realloc_Realloc: + mov edx, [esp + 8] //size + test edx, edx + jnz realloc_DoRealloc + call InternalFreeMem + realloc_ReturnNULL: + xor eax, eax + realloc_Exit2: + ret + realloc_DoRealloc: + #if __BORLANDC__ >= 0x564 + jmp InternalReallocMem + //ret + #else + call InternalReallocMem + ret + #endif + } +} + +__declspec(naked) void _RTLENTRY Cpp_terminate_Stub(void) +{ + //Do nothing + asm ret; +} +#endif + +#ifdef DetectMMOperationsAfterUninstall + +GetMemFunc InvalidGetMemPtr; +FreeMemFunc InvalidFreeMemPtr; +ReallocMemFunc InvalidReallocMemPtr; + +#if defined(PURE_CPLUSPLUS) //__BORLANDC__ < 0x0560 + +void * _RTLENTRY Cpp_Invalid_malloc_Stub(size_t size) +{ + if (size) + return (*InvalidGetMemPtr)(size); + else + return NULL; +} + +void _RTLENTRY Cpp_Invalid_free_Stub(void *block) +{ + if (block) + (*InvalidFreeMemPtr)(block); +} + +void * _RTLENTRY Cpp_Invalid_realloc_Stub(void *block, size_t size) +{ + if (!block) + { + if (size) + return (*InvalidGetMemPtr)(size); + else + return NULL; + } + else { + if (!size) + { + (*InvalidFreeMemPtr)(block); + return NULL; + } + else + return (*InvalidReallocMemPtr)(block, size); + } +} + +#else + +//#pragma warn -8002 //"W8002: Restarting compile using assembly" +#pragma option -w-asc + +//#pragma warn -8070 //"W8070 Function should return a value" +#pragma option -w-rvl //the same as above + +__declspec(naked) void * _RTLENTRY Cpp_Invalid_malloc_Stub(size_t size) +{ + asm + { + mov eax, [esp + 4] //size + test eax, eax + jz Invalid_malloc_Exit + #if __BORLANDC__ >= 0x564 + jmp InvalidGetMemPtr + nop + #else + call InvalidGetMemPtr + ret + #endif + nop + Invalid_malloc_Exit: + ret + } +} + +__declspec(naked) void _RTLENTRY Cpp_Invalid_free_Stub(void *block) +{ + asm + { + mov eax, [esp + 4] //block + test eax, eax + jz Invalid_free_Exit + #if __BORLANDC__ >= 0x564 + jmp InvalidFreeMemPtr + nop + #else + call InvalidFreeMemPtr + ret + #endif + nop + Invalid_free_Exit: + ret + } +} + +__declspec(naked) void * _RTLENTRY Cpp_Invalid_realloc_Stub(void *block, size_t size) +{ + asm + { + mov eax, [esp + 4] //block + test eax, eax + jnz Invalid_realloc_Realloc + Invalid_realloc_Alloc: + mov eax, [esp + 8] //size + test eax, eax + jz Invalid_realloc_Exit2 //Invalid_realloc_Exit1 + #if __BORLANDC__ >= 0x564 + jmp InvalidGetMemPtr + nop + #else + call InvalidGetMemPtr + ret + #endif + nop + //Invalid_realloc_Exit1: + //ret + Invalid_realloc_Realloc: + mov edx, [esp + 8] //size + test edx, edx + jnz Invalid_realloc_DoRealloc + call InvalidFreeMemPtr + Invalid_realloc_ReturnNULL: + xor eax, eax + Invalid_realloc_Exit2: + ret + nop + nop + nop + Invalid_realloc_DoRealloc: + #if __BORLANDC__ >= 0x564 + jmp InvalidReallocMemPtr + //ret + #else + call InvalidReallocMemPtr + ret + #endif + } +} +#endif + +#endif //DetectMMOperationsAfterUninstall + +#pragma option push -b -a8 + +typedef void (_RTLENTRY *HeapRedirect_free) (void *); +typedef void * (_RTLENTRY *HeapRedirect_malloc) (size_t); +typedef void * (_RTLENTRY *HeapRedirect_realloc) (void *, size_t); +typedef void (_RTLENTRY *HeapRedirect_terminate) (void); + +typedef enum +{ + hrfVirgin, + hrfInternal, + hrfBorlndmm, + hrfOldBorlndmm, + hrfVCLSystem, + hrfDgbAlloc, + hrfOther +} HeapRedirectFlag; + +typedef struct +{ + size_t size; + unsigned int allocated; + HeapRedirectFlag flags; + HeapRedirect_free free; + HeapRedirect_malloc malloc; + HeapRedirect_realloc realloc; + HeapRedirect_terminate terminate; +} HeapRedirector; + +typedef struct HeapRedirectorStoreStruct +{ + HeapRedirector Data; + HMODULE Module; + void * PatchAddress; + TRelativeJmp32 PatchBackup; + struct HeapRedirectorStoreStruct *Next; +} HeapRedirectorStore, *HeapRedirectorStorePtr; + +extern HeapRedirector * _RTLENTRY _EXPFUNC _get_heap_redirector_info(void); +typedef HeapRedirector * _RTLENTRY _EXPFUNC (* rtl_get_heap_redirector_info_func)(void); + +#pragma option pop + +HeapRedirector * pHRDir = NULL; +HeapRedirector Old_heap_redirector; + +HeapRedirectorStorePtr HeapRedirectorStoreListHeader = NULL; + +//#endif //!_RTLDLL + + +#define UseHeap + +#ifdef UseHeap +HANDLE ProcessHeapHandle = NULL; +#endif + +void __fastcall InitFinalMemMgr(void) +{ + #ifdef UseHeap + if (!ProcessHeapHandle) + { + ProcessHeapHandle = GetProcessHeap(); + } + #endif +} + +void * __fastcall FinalGetMem(unsigned ASize) +{ + #ifdef UseHeap + return HeapAlloc(ProcessHeapHandle, HEAP_GENERATE_EXCEPTIONS, ASize); + #else + return malloc(ASize); + #endif +} + +void __fastcall FinalFreeMem(void * ABlock) +{ + #ifdef UseHeap + HeapFree(ProcessHeapHandle, 0, ABlock); + #else + free(ABlock); + #endif +} + +void * __fastcall FinalReallocMem(void * ABlock, unsigned ANewSize) +{ + #ifdef UseHeap + return HeapReAlloc(ProcessHeapHandle, HEAP_GENERATE_EXCEPTIONS, ABlock, ANewSize); + #else + return realloc(ABlock, ANewSize); + #endif +} + +void __fastcall FinalizeHeapRedirectorStoreList(void) +{ + if (HeapRedirectorStoreListHeader) + { + HeapRedirectorStorePtr next, ptr = HeapRedirectorStoreListHeader; + HeapRedirectorStoreListHeader = NULL; + + while (ptr) + { + next = ptr->Next; + + FinalFreeMem(ptr); + + ptr = next; + } + } +} + +typedef bool __fastcall (* EnumModuleCallback)(HMODULE AModule, void *AParam); + +#define PSAPI _TEXT("psapi") + +bool __fastcall EnumModulesWinNT(EnumModuleCallback ACallback, void *AParam) +{ + typedef BOOL (__stdcall * EnumProcessModulesType)(HANDLE hProcess, + HMODULE* lphModule, + DWORD cb, + LPDWORD lpcbNeeded + ); + + if (!ACallback) + { + return false; + } + + EnumProcessModulesType EnumProcessModules; + bool DynamicLoaded; + + HMODULE PsapiLib = GetModuleHandle(PSAPI); + if (!PsapiLib) + { + PsapiLib = LoadLibrary(PSAPI); + if (!PsapiLib) + { + return false; + } + DynamicLoaded = true; + } + else { + DynamicLoaded = false; + } + + InitFinalMemMgr(); + + bool ret = false; + + try + { + EnumProcessModules = (EnumProcessModulesType)GetProcAddress(PsapiLib, + "EnumProcessModules"); + + if (EnumProcessModules) + { + HANDLE hProcess = OpenProcess(PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, + FALSE, GetCurrentProcessId()); + if (hProcess) + { + try + { + DWORD cbNeeded = 0; + if (EnumProcessModules(hProcess, NULL, 0, &cbNeeded)) + { + HMODULE * hMod = (HMODULE *)FinalGetMem(cbNeeded); + try + { + if (EnumProcessModules(hProcess, hMod, cbNeeded, &cbNeeded)) + { + for (unsigned int i = 0; i < (cbNeeded / sizeof(HMODULE)); i++) + { + if (!ACallback(hMod[i], AParam)) + { + break; + } + } + ret = true; + } + } + __finally + { + FinalFreeMem(hMod); + } + } + } + __finally + { + CloseHandle(hProcess); + } + } + } + } + __finally + { + if (DynamicLoaded) + { + FreeLibrary(PsapiLib); + } + } + + return ret; +} + +#define KERNEL32 _TEXT("kernel32") + +bool __fastcall EnumModulesWin9x(EnumModuleCallback ACallback, void *AParam) +{ +#define MAX_MODULE_NAME32 255 +#define TH32CS_SNAPMODULE 0x00000008 + + typedef struct tagMODULEENTRY32 + { + DWORD dwSize; + DWORD th32ModuleID; + DWORD th32ProcessID; + DWORD GlblcntUsage; + DWORD ProccntUsage; + BYTE * modBaseAddr; + DWORD modBaseSize; + HMODULE hModule; + char szModule[MAX_MODULE_NAME32 + 1]; + char szExePath[MAX_PATH]; + } MODULEENTRY32; + typedef MODULEENTRY32 * PMODULEENTRY32; + typedef MODULEENTRY32 * LPMODULEENTRY32; + + typedef HANDLE (__stdcall * CreateToolhelp32SnapshotType)(DWORD dwFlags, + DWORD th32ProcessID); + typedef BOOL (__stdcall * Module32FirstType)(HANDLE hSnapshot, LPMODULEENTRY32 lpme); + typedef BOOL (__stdcall * Module32NextType)(HANDLE hSnapshot, LPMODULEENTRY32 lpme); + + if (!ACallback) + { + return false; + } + + HMODULE Kernel32Lib; + HANDLE hSnapshot; + CreateToolhelp32SnapshotType CreateToolhelp32Snapshot; + Module32FirstType Module32First; + Module32NextType Module32Next; + bool ret = false; + + Kernel32Lib = GetModuleHandle(KERNEL32); + if (Kernel32Lib) + { + CreateToolhelp32Snapshot = (CreateToolhelp32SnapshotType)GetProcAddress(Kernel32Lib, + "CreateToolhelp32Snapshot"); + Module32First = (Module32FirstType)GetProcAddress(Kernel32Lib, "Module32First"); + Module32Next = (Module32NextType)GetProcAddress(Kernel32Lib, "Module32Next"); + if ((CreateToolhelp32Snapshot) && (Module32First) && (Module32Next)) + { + hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId()); + if (hSnapshot != INVALID_HANDLE_VALUE) + { + try + { + MODULEENTRY32 ModuleInfo = {0}; + ModuleInfo.dwSize = sizeof(ModuleInfo); + + while (Module32First(hSnapshot, &ModuleInfo)) + { + if (!ACallback(ModuleInfo.hModule, AParam)) + break; + } + ret = true; + } + __finally + { + CloseHandle(hSnapshot); + } + } + } + } + return ret; +} + +bool __fastcall EnumModules(EnumModuleCallback ACallback, void *AParam) +{ + if (ACallback) + { + OSVERSIONINFO OSVersionInfo; + + OSVersionInfo.dwOSVersionInfoSize = sizeof(OSVersionInfo); + if (GetVersionEx(&OSVersionInfo)) + { + if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT) + { + return EnumModulesWinNT(ACallback, AParam); + } + else { + return EnumModulesWin9x(ACallback, AParam); + } + } + } + return false; +} + +#ifdef CheckCppObjectTypeEnabled + +typedef struct { + DWORD CodeSecStart; + DWORD DataSecStart; + DWORD DataSecEnd; +} ModuleCodeDataRanges, * PModuleCodeDataRanges; + +int ModuleCodeDataRangesCount = 0; +int ModuleCodeDataRangesCapacity = 0; +PModuleCodeDataRanges gpModuleCodeDataRanges = NULL; +unsigned LowestDataAddr = NULL; +unsigned HighestDataAddr = NULL; + +bool __fastcall FindCodeDataRangeByDataAddr(DWORD ADataAddr, int * Index, + PModuleCodeDataRanges * ARange) +{ + bool ret = false; + int L, H, I; + L = 0; + H = ModuleCodeDataRangesCount - 1; + while (L <= H) + { + I = (L + H) / 2; + DWORD AStart = gpModuleCodeDataRanges[I].DataSecStart; + DWORD AEnd = gpModuleCodeDataRanges[I].DataSecEnd; + if (ADataAddr < AStart) + { + H = I - 1; + } + else if (ADataAddr >= AEnd) + { + L = I + 1; + } + else { + if (ARange) + { + *ARange = &(gpModuleCodeDataRanges[I]); + } + L = I; + ret = true; + break; + } + + } + + if (Index) + { + *Index = L; + } + + return ret; +} + +bool __fastcall FindCodeDataRangeByCodeAddr(DWORD ACodeAddr, int * Index, + PModuleCodeDataRanges * ARange) +{ + bool ret = false; + int L, H, I; + L = 0; + H = ModuleCodeDataRangesCount - 1; + while (L <= H) + { + I = (L + H) / 2; + DWORD AStart = gpModuleCodeDataRanges[I].CodeSecStart; + DWORD AEnd = gpModuleCodeDataRanges[I].DataSecStart; + if (ACodeAddr < AStart) + { + H = I - 1; + } + else if (ACodeAddr >= AEnd) + { + L = I + 1; + } + else { + if (ARange) + { + *ARange = &(gpModuleCodeDataRanges[I]); + } + L = I; + ret = true; + break; + } + } + + if (Index) + { + *Index = L; + } + + return ret; +} + +PIMAGE_SECTION_HEADER __fastcall GetImageFirstSection(PIMAGE_NT_HEADERS ntheader) +{ + return (PIMAGE_SECTION_HEADER)((unsigned)&(ntheader->OptionalHeader) + + ntheader->FileHeader.SizeOfOptionalHeader); +} + +#define DefaultCodeSectionName _TEXT(".text") +#define DefaultDataSectionName _TEXT(".data") + +bool __fastcall AddModuleCodeDataRange(HMODULE AModule, void *AParam) +{ + if ((FindResource(AModule, DVCLALResName, RT_RCDATA)) + /*&& (GetProcAddress(AModule, CPPdebugHookExport))*/) + { + PIMAGE_NT_HEADERS ntheader = (PIMAGE_NT_HEADERS)((unsigned)AModule + + ((PIMAGE_DOS_HEADER)AModule)->e_lfanew); + PIMAGE_SECTION_HEADER CodeSecHeader = GetImageFirstSection(ntheader); + //= IMAGE_FIRST_SECTION(ntheader); + PIMAGE_SECTION_HEADER DataSecHeader = CodeSecHeader + 1; + if (((memcmp(DefaultCodeSectionName, CodeSecHeader->Name, 5)) == 0) + && (CodeSecHeader->Characteristics == (IMAGE_SCN_MEM_EXECUTE + | IMAGE_SCN_MEM_READ | IMAGE_SCN_CNT_CODE)) + && ((memcmp(DefaultDataSectionName, DataSecHeader->Name, 5)) == 0) + && (DataSecHeader->Characteristics == (IMAGE_SCN_MEM_WRITE + | IMAGE_SCN_MEM_READ | IMAGE_SCN_CNT_INITIALIZED_DATA))) + { + + int Index; + if (!FindCodeDataRangeByDataAddr((unsigned)AModule + + DataSecHeader->VirtualAddress, &Index, NULL)) + { + + int NewCount = ModuleCodeDataRangesCount + 1; + if (NewCount >= ModuleCodeDataRangesCapacity) + { + //Realloc + int NewCapacity = ModuleCodeDataRangesCapacity + + (ModuleCodeDataRangesCapacity / 4); + gpModuleCodeDataRanges = + (PModuleCodeDataRanges)FinalReallocMem(gpModuleCodeDataRanges, + sizeof(ModuleCodeDataRanges) * NewCapacity); + ModuleCodeDataRangesCapacity = NewCapacity; + } + + ModuleCodeDataRangesCount = NewCount; + + gpModuleCodeDataRanges[Index].CodeSecStart = (unsigned)AModule + + CodeSecHeader->VirtualAddress; + gpModuleCodeDataRanges[Index].DataSecStart = (unsigned)AModule + + DataSecHeader->VirtualAddress; + gpModuleCodeDataRanges[Index].DataSecEnd = (unsigned)AModule + + DataSecHeader->VirtualAddress + DataSecHeader->Misc.VirtualSize; + } + } + } + + return true; +} + +void __fastcall FinalizeModuleCodeDataRanges(void) +{ + if ((unsigned)gpModuleCodeDataRanges > 1) + { + FinalFreeMem(gpModuleCodeDataRanges); + gpModuleCodeDataRanges = NULL; + ModuleCodeDataRangesCount = 0; + ModuleCodeDataRangesCapacity = NULL; + } +} + +#define InitialCodeDataRangeCount 256 + +bool __fastcall FillModuleCodeDataRanges(void) +{ + if (!gpModuleCodeDataRanges) + { + InitFinalMemMgr(); + + gpModuleCodeDataRanges = + (PModuleCodeDataRanges)FinalGetMem(sizeof(ModuleCodeDataRanges) + * InitialCodeDataRangeCount); + ModuleCodeDataRangesCapacity = InitialCodeDataRangeCount; + + bool ret = EnumModules(AddModuleCodeDataRange, NULL); + if ((!ret) || (!ModuleCodeDataRangesCount)) + { + FinalizeModuleCodeDataRanges(); + gpModuleCodeDataRanges = (PModuleCodeDataRanges)1; + + return false; + } + + if (ret) + { + LowestDataAddr = gpModuleCodeDataRanges->DataSecStart; + HighestDataAddr = + gpModuleCodeDataRanges[ModuleCodeDataRangesCount - 1].DataSecEnd + - sizeof(void *); + } + return ret; + } + else { + return false; + } +} + +#pragma option push -a1 + +struct TypeDescriptor; +typedef TypeDescriptor * TypeDescriptorPtr; + +struct TypeDescriptor +{ + unsigned Size; + unsigned short Mask; + unsigned short Name; + + union + { + struct + { + unsigned VTablePtrOffset; + unsigned Flags; + } + Class; + }; +}; + + +//TypeDescriptor.Mask flags + +#define TYPE_MASK_IS_STRUCT 0x0001 +#define TYPE_MASK_IS_CLASS 0x0002 + +#define CLASS_FLAG_HAS_VTABPTR 0x00000010 +#define CLASS_FLAG_HAS_RTTI 0x00000040 + +#pragma option pop + + +TypeDescriptorPtr __fastcall GetCppVirtualObjectTypeIdPtrByVTablePtr(void * AVTablePtr, + unsigned AVTablePtrOffset) +{ + if (AVTablePtr) + { + if ((!((unsigned)AVTablePtr & (sizeof(void *) - 1))) + && (!((unsigned)AVTablePtrOffset & (sizeof(void *) - 1)))) + { + if (!gpModuleCodeDataRanges) + { + if (!FillModuleCodeDataRanges()) + { + return NULL; + } + } + + if (((unsigned)AVTablePtr >= LowestDataAddr) && ((unsigned)AVTablePtr <= HighestDataAddr)) + { + PModuleCodeDataRanges ADataRange, ACodeRange; + + if (FindCodeDataRangeByDataAddr((unsigned)AVTablePtr + - (sizeof(unsigned) * 4), NULL, &ADataRange)) + { + //maybe vtableptr + unsigned * vftPtr = (unsigned *)AVTablePtr; + unsigned VMFuncAddr = *vftPtr; + if (((VMFuncAddr >= ADataRange->CodeSecStart) + && (VMFuncAddr < ADataRange->DataSecStart)) + || (FindCodeDataRangeByCodeAddr(VMFuncAddr, NULL, &ACodeRange))) + { + //address of virtual member function is valid + unsigned varOffset = vftPtr[-2]; + unsigned rttiPtrOffset = vftPtr[-1]; + if (varOffset <= AVTablePtrOffset) + { + unsigned rttiPtr = (unsigned)((char *)vftPtr - rttiPtrOffset); + if ((rttiPtr >= ADataRange->DataSecStart) + && (((unsigned *)rttiPtr)[-1] == 0)) + { //rtti Ptr is valid + TypeDescriptorPtr mdtpidPtr = *((TypeDescriptorPtr *)((unsigned *)rttiPtr - 2) - 1); + if (((unsigned)mdtpidPtr > ADataRange->CodeSecStart) + && (((unsigned)mdtpidPtr + (sizeof(TypeDescriptor) - sizeof(GUID))) + < ADataRange->DataSecStart)) + { //tpid data in code section + if ((mdtpidPtr->Size >= (AVTablePtrOffset + sizeof(void *))) + && (mdtpidPtr->Class.VTablePtrOffset == AVTablePtrOffset) + && (mdtpidPtr->Mask & (TYPE_MASK_IS_STRUCT | TYPE_MASK_IS_CLASS)) + && (mdtpidPtr->Class.Flags & (CLASS_FLAG_HAS_VTABPTR | CLASS_FLAG_HAS_RTTI))) + { //tpid data valid ? + unsigned char * TypeName = (unsigned char *)mdtpidPtr + + mdtpidPtr->Name; + if ((((unsigned)TypeName + sizeof(unsigned char) * 2) + < ADataRange->DataSecStart) && (*TypeName <= 'z')) + { + return mdtpidPtr; + } + } + } + } + } + } + + } + } + } + } + return NULL; +} + +//#define CheckVirtualRootBaseFirst //Returned may not be the most derived type + +TypeDescriptorPtr __fastcall GetCppVirtualObjectTypeIdPtr(void * APointer, unsigned ASize) +{ + if ((APointer) && (ASize >= sizeof(void *))) + { + if (!((unsigned)APointer & (sizeof(void *) - 1))) + { + if (!gpModuleCodeDataRanges) + { + if (!FillModuleCodeDataRanges()) + { + return NULL; + } + } + #ifdef CheckVirtualRootBaseFirst + TypeDescriptorPtr ret = GetCppVirtualObjectTypeIdPtrByVTablePtr(*((void **)APointer), 0); + if (ret) + { + return ret; + } + #endif + PModuleCodeDataRanges ADataRange, ACodeRange; + unsigned ObjectSize = ASize; + + ASize = ASize - (ASize & (sizeof(void *) - 1)) - sizeof(void *); + + unsigned * DataPtr = (unsigned *)((char *)APointer + ASize); + + #ifdef CheckVirtualRootBaseFirst + while (DataPtr > (unsigned *)APointer) + #else + while (DataPtr >= (unsigned *)APointer) + #endif + { + unsigned Data = *DataPtr; + if ((Data >= LowestDataAddr) && (Data <= HighestDataAddr)) + { + if (FindCodeDataRangeByDataAddr(Data - (sizeof(unsigned) * 4), + NULL, &ADataRange)) + { + //maybe vtableptr + unsigned * vftPtr = (unsigned *)Data; + unsigned VMFuncAddr = *vftPtr; + if (((VMFuncAddr >= ADataRange->CodeSecStart) + && (VMFuncAddr < ADataRange->DataSecStart)) + || (FindCodeDataRangeByCodeAddr(VMFuncAddr, NULL, &ACodeRange))) + { + //address of virtual member function is valid + unsigned varOffset = vftPtr[-2]; + unsigned rttiPtrOffset = vftPtr[-1]; + unsigned vftPtrOffset = (char *)DataPtr - (char *)APointer; + if (varOffset <= vftPtrOffset) + { + unsigned rttiPtr = (unsigned)((char *)vftPtr - rttiPtrOffset); + if ((rttiPtr >= ADataRange->DataSecStart) + && (((unsigned *)rttiPtr)[-1] == 0)) + { //rtti Ptr is valid + TypeDescriptorPtr mdtpidPtr = *((TypeDescriptorPtr *)((unsigned *)rttiPtr - 2) - 1); + if (((unsigned)mdtpidPtr > ADataRange->CodeSecStart) + && (((unsigned)mdtpidPtr + (sizeof(TypeDescriptor) - sizeof(GUID))) + < ADataRange->DataSecStart)) + { //tpid data in code section + if ((mdtpidPtr->Size <= ObjectSize) + && (mdtpidPtr->Class.VTablePtrOffset == vftPtrOffset) + && (mdtpidPtr->Mask & (TYPE_MASK_IS_STRUCT | TYPE_MASK_IS_CLASS)) + && (mdtpidPtr->Class.Flags & (CLASS_FLAG_HAS_VTABPTR | CLASS_FLAG_HAS_RTTI))) + { //tpid data valid ? + unsigned char * TypeName = (unsigned char *)mdtpidPtr + + mdtpidPtr->Name; + if ((((unsigned)TypeName + sizeof(unsigned char) * 2) + < ADataRange->DataSecStart) && (*TypeName <= 'z')) + { + return mdtpidPtr; + } + } + } + } + } + } + + } + } + DataPtr--; + } + } + } + return NULL; +} + + +char * __fastcall GetCppVirtualObjectTypeName(void * APointer, unsigned ASize) +{ + TypeDescriptorPtr AtpidPtr = GetCppVirtualObjectTypeIdPtr(APointer, ASize); + if (AtpidPtr) + { + return (char *)AtpidPtr + AtpidPtr->Name; + } + else { + return NULL; + } +} + +char * __fastcall GetCppVirtualObjectTypeNameByVTablePtr(void * AVTablePtr, + unsigned AVTablePtrOffset) +{ + TypeDescriptorPtr AtpidPtr = GetCppVirtualObjectTypeIdPtrByVTablePtr(AVTablePtr, + AVTablePtrOffset); + if (AtpidPtr) + { + return (char *)AtpidPtr + AtpidPtr->Name; + } + else { + return NULL; + } +} + +unsigned __fastcall GetCppVirtualObjectSizeByTypeIdPtr(TypeDescriptorPtr AtpidPtr) +{ + if ((AtpidPtr) + && (AtpidPtr->Mask & (TYPE_MASK_IS_STRUCT | TYPE_MASK_IS_CLASS)) + && (AtpidPtr->Class.Flags & (CLASS_FLAG_HAS_VTABPTR | CLASS_FLAG_HAS_RTTI))) + { + return AtpidPtr->Size; + } + else { + return 0; + } +} + +char * __fastcall GetCppVirtualObjectTypeNameByTypeIdPtr(TypeDescriptorPtr AtpidPtr) +{ + if (AtpidPtr) + { + return (char *)AtpidPtr + AtpidPtr->Name; + } + else { + return NULL; + } +} + +#endif //CheckCppObjectTypeEnabled + +#define BORLANDMM _TEXT("borlndmm") + +#define CRTL_MEM_SIGNATURE_EXPORT "___CRTL_MEM_GetBorMemPtrs" +#define CRTL_GET_HEAP_REDIRECTOR_INFO "__get_heap_redirector_info" + +bool __fastcall TryHookRTLHeapRedirector(HMODULE AModule, void *AParam) +{ + if ((FindResource(AModule, DVCLALResName, RT_RCDATA)) + /*&& (GetProcAddress(AModule, CPPdebugHookExport))*/ + && (GetProcAddress(AModule, CRTL_MEM_SIGNATURE_EXPORT))) + { + rtl_get_heap_redirector_info_func rtl_get_heap_redirector_info; + rtl_get_heap_redirector_info + = (rtl_get_heap_redirector_info_func)GetProcAddress(AModule, CRTL_GET_HEAP_REDIRECTOR_INFO); + if (rtl_get_heap_redirector_info) + { + HeapRedirector * pHRDir = (*rtl_get_heap_redirector_info)(); + if (pHRDir) + { + if ((pHRDir->flags < hrfBorlndmm) || (pHRDir->flags == hrfVCLSystem)) + { + void * PatchAddr; + + HeapRedirectorStorePtr node = (HeapRedirectorStorePtr)FinalGetMem(sizeof(HeapRedirectorStore)); + node->Data = *pHRDir; + node->Module = AModule; + + //insert node into store list + node->Next = HeapRedirectorStoreListHeader; + HeapRedirectorStoreListHeader = node; + + pHRDir->malloc = &Cpp_malloc_Stub; + pHRDir->free = &Cpp_free_Stub; + pHRDir->realloc = &Cpp_realloc_Stub; + pHRDir->terminate = &Cpp_terminate_Stub; + pHRDir->flags = hrfOther; + + pHRDir->allocated = 1; + + //patch RTL _terminate of this module + PatchAddr = GetProcAddress(AModule, _terminateExport); + if ((PatchAddr) && (((PRelativeJmp32)PatchAddr)->JmpInst != RelativeJmp32Inst) + && (!PatchProc(PatchAddr, &New_terminate, &node->PatchBackup))) + { + node->PatchAddress = PatchAddr; + } + else + { + node->PatchAddress = NULL; + } + } + } + } + } + + return true; +} + +bool __fastcall TryUnhookRTLHeapRedirector(HMODULE AModule, void *AParam) +{ + if ((FindResource(AModule, DVCLALResName, RT_RCDATA)) + /*&& (GetProcAddress(AModule, CPPdebugHookExport))*/ + && (GetProcAddress(AModule, CRTL_MEM_SIGNATURE_EXPORT))) + { + rtl_get_heap_redirector_info_func rtl_get_heap_redirector_info; + rtl_get_heap_redirector_info + = (rtl_get_heap_redirector_info_func)GetProcAddress(AModule, CRTL_GET_HEAP_REDIRECTOR_INFO); + if (rtl_get_heap_redirector_info) + { + HeapRedirector * pHRDir = (*rtl_get_heap_redirector_info)(); + if (pHRDir) + { + //restore and remove store node + { + HeapRedirectorStorePtr prev, node; + + prev = NULL; + node = HeapRedirectorStoreListHeader; + while (node) + { + if (node->Module == AModule) + { + //restore original heap redirector + if ((pHRDir->flags == hrfOther) + && (pHRDir->malloc == &Cpp_malloc_Stub) + && (pHRDir->free == &Cpp_free_Stub) + && (pHRDir->realloc == &Cpp_realloc_Stub) + && (pHRDir->terminate == &Cpp_terminate_Stub) + ) + { + #ifdef DetectMMOperationsAfterUninstall + if ((bool)AParam) + { + pHRDir->malloc = &Cpp_Invalid_malloc_Stub; + pHRDir->free = &Cpp_Invalid_free_Stub; + pHRDir->realloc = &Cpp_Invalid_realloc_Stub; + } + else + #endif + *pHRDir = node->Data; + } + + //restore RTL _terminate of this module + if (node->PatchAddress) + { + UnPatchProc(node->PatchAddress, &New_terminate, &node->PatchBackup); + } + + //remove node from store list + if (prev) + { + prev->Next = node->Next; + } + else + { + HeapRedirectorStoreListHeader = node->Next; + } + + FinalFreeMem(node); + + break; + } + else + { + prev = node; + node = node->Next; + } + } + } + } + } + } + + return true; +} + +#endif //PatchBCBTerminate + + +void BCBInstallFastMM() +{ +//#ifdef __DLL__ //not defined even with -tWD ? +//#endif + +//#if ((!defined(_NO_VCL)) && defined(__DLL__) && defined(_RTLDLL)) + //borlndmm.dll will linked in +//#else + InitializeMemoryManager(); + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + //CheckCanInstallMemoryManager will finally call System.GetHeapStatus which is the + //internal shipped copy of FastGetHeapStatus routine, but the InitializeMemoryManager + //routine of that copy is not called yet at this point, and thus System.GetHeapStatus + //will generate an access violation exception. + //Currently avoid this exception by skip the check + #ifndef _NO_VCL + if (CheckCanInstallMemoryManager()) + #endif //!_NO_VCL + #else + if (CheckCanInstallMemoryManager()) + #endif //< BDS2006 + { + #ifdef PatchBCBTerminate + #if defined(__DLL__) && defined(FullDebugMode) && defined(LoadDebugDLLDynamically) + //if FastMM_FullDebugMode.dll receive DLL_PROCESS_DETACH before + //calling FinalizeMemoryManager, exception will occur when calling + //LogStackTrace in FastMM_FullDebugMode.dll, the following call + //will delay the processing of DLL_PROCESS_DETACH in DllMain of + //FastMM_FullDebugMode.dll + if (!TryHookFullDebugModeDllEntry()) + { + return; + } + #endif + #endif + + #ifdef FullDebugMode + #ifdef ClearLogFileOnStartup + DeleteEventLog(); + #endif //ClearLogFileOnStartup + #endif //FullDebugMode + + #ifdef PatchBCBTerminate + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + System::TMemoryManagerEx AMemoryManager; + #else + System::TMemoryManager AMemoryManager; + #endif + System::GetMemoryManager(AMemoryManager); + StockGetMemPtr = AMemoryManager.GetMem; + #endif + + InstallMemoryManager(); + +#if __BORLANDC__ < 0x0560 + #if !defined(PURE_CPLUSPLUS) + #if !defined(PatchBCBTerminate) + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + System::TMemoryManagerEx AMemoryManager; + #else + System::TMemoryManager AMemoryManager; + #endif + #endif + System::GetMemoryManager(AMemoryManager); + + GetMemPtr = AMemoryManager.GetMem; + FreeMemPtr = AMemoryManager.FreeMem; + ReallocMemPtr = AMemoryManager.ReallocMem; + #endif +#endif + + #ifdef PatchBCBTerminate + IsMMInstalled = true; + #endif + + #ifdef PatchBCBTerminate + + HMODULE ThisModule = (HMODULE)System::FindHInstance(&BCBInstallFastMM); + HMODULE MainModule = GetModuleHandle(0); + + //#ifndef _RTLDLL + HMODULE BorlandMM_Module = GetModuleHandle(BORLANDMM); + if (!BorlandMM_Module) + { + pHRDir = _get_heap_redirector_info(); + if (pHRDir) + { + if ((pHRDir->flags < hrfBorlndmm) || (pHRDir->flags == hrfVCLSystem)) + { + Old_heap_redirector = *pHRDir; + + pHRDir->malloc = &Cpp_malloc_Stub; + pHRDir->free = &Cpp_free_Stub; + pHRDir->realloc = &Cpp_realloc_Stub; + pHRDir->terminate = &Cpp_terminate_Stub; + pHRDir->flags = hrfOther; + + pHRDir->allocated = 1; + } + else { + pHRDir = NULL; + } + } + } + else + { + if (BorlandMM_Module == ThisModule) + { + IsBorlandMMDLL = true; + //Try hook heap redirector of RTL modules + EnumModules(TryHookRTLHeapRedirector, NULL); + } + } + //#endif //!_RTLDLL + + pCppDebugHook = (int *)(GetProcAddress(MainModule, CPPdebugHookExport)); + if (!pCppDebugHook) + { + pCppDebugHook = &__CPPdebugHook; + } + #ifdef CheckCppObjectTypeEnabled + GetCppVirtObjSizeByTypeIdPtrFunc = + (TGetCppVirtObjSizeByTypeIdPtrFunc)&GetCppVirtualObjectSizeByTypeIdPtr; + + GetCppVirtObjTypeIdPtrFunc = + (TGetCppVirtObjTypeIdPtrFunc)&GetCppVirtualObjectTypeIdPtr; + + GetCppVirtObjTypeNameFunc = + (TGetCppVirtObjTypeNameFunc)&GetCppVirtualObjectTypeName; + + GetCppVirtObjTypeNameByTypeIdPtrFunc = + (TGetCppVirtObjTypeNameByTypeIdPtrFunc)&GetCppVirtualObjectTypeNameByTypeIdPtr; + + GetCppVirtObjTypeNameByVTablePtrFunc = + (TGetCppVirtObjTypeNameByVTablePtrFunc)&GetCppVirtualObjectTypeNameByVTablePtr; + #endif + + IsInDLL = (MainModule != ThisModule); + if (!IsInDLL) + { + if (Patch_terminate()) + { + terminatePatched = true; + + #ifdef EnableMemoryLeakReporting + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + //"ios.cpp", line 136, ios_base::_Init(), "locale" leaks + RegisterExpectedMemoryLeak(20, 8); + //"locale0.cpp", line 167, locale::_Init(), "_Locimp" leak due to above leaks + RegisterExpectedMemoryLeak(68, 1); + #endif + #endif + } + } + #ifndef _RTLDLL + else + { + #ifdef EnableMemoryLeakReporting + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + //"ios.cpp", line 136, ios_base::_Init(), "locale" leaks + RegisterExpectedMemoryLeak(20, 8); + //"locale0.cpp", line 167, locale::_Init(), "_Locimp" leak due to above leaks + RegisterExpectedMemoryLeak(68, 1); + + RegisterExpectedMemoryLeak(228, 1); + #endif + #endif + } + #endif //_RTLDLL + + #endif //PatchBCBTerminate + } +//#endif +} +#pragma startup BCBInstallFastMM 0 + +#ifdef PatchBCBTerminate + +void BCBUninstallFastMM() +{ + //Sadly we cannot uninstall here since there are still live pointers. +//#if ((!defined(_NO_VCL)) && defined(__DLL__) && defined(_RTLDLL)) + +//#else + if (IsMMInstalled && (!terminatePatched)) + { + //Delphi MemoryManager already installed here + FinalizeMemoryManager(); + + #if __BORLANDC__ >= 0x582 + //>= BDS2006 ? + System::TMemoryManagerEx AMemoryManager; + #else + System::TMemoryManager AMemoryManager; + #endif + System::GetMemoryManager(AMemoryManager); + + //MemoryManager uninstalled ? + bool DelphiMMUninstalled = (AMemoryManager.GetMem != InternalGetMem); + #ifdef DetectMMOperationsAfterUninstall + //InvalidMemoryManager get set as Delphi MemoryManager ? + bool InvalidMMSet = (AMemoryManager.GetMem != StockGetMemPtr); + #endif + +#if __BORLANDC__ < 0x0560 + #if !defined(PURE_CPLUSPLUS) + GetMemPtr = NULL; + FreeMemPtr = NULL; + ReallocMemPtr = NULL; + #endif +#endif + + #ifdef CheckCppObjectTypeEnabled + GetCppVirtObjSizeByTypeIdPtrFunc = NULL; + GetCppVirtObjTypeIdPtrFunc = NULL; + GetCppVirtObjTypeNameFunc = NULL; + GetCppVirtObjTypeNameByTypeIdPtrFunc = NULL; + GetCppVirtObjTypeNameByVTablePtrFunc = NULL; + + FinalizeModuleCodeDataRanges(); + #endif + + if (DelphiMMUninstalled) + { + if (pHRDir) + { + #ifdef DetectMMOperationsAfterUninstall + if (InvalidMMSet) + { + InvalidGetMemPtr = AMemoryManager.GetMem; + InvalidFreeMemPtr = AMemoryManager.FreeMem; + InvalidReallocMemPtr = AMemoryManager.ReallocMem; + + pHRDir->malloc = Cpp_Invalid_malloc_Stub; + pHRDir->free = Cpp_Invalid_free_Stub; + pHRDir->realloc = Cpp_Invalid_realloc_Stub; + } + else + #endif + *pHRDir = Old_heap_redirector; + + pHRDir = NULL; + } + else + { + if (IsBorlandMMDLL) + { + //Try unhook heap redirector of RTL modules + #ifdef DetectMMOperationsAfterUninstall + EnumModules(TryUnhookRTLHeapRedirector, (void *)InvalidMMSet); + #else + EnumModules(TryUnhookRTLHeapRedirector, NULL); + #endif + FinalizeHeapRedirectorStoreList(); + } + } + } + + #if defined(__DLL__) && defined(FullDebugMode) && defined(LoadDebugDLLDynamically) + CallOldFullDebugModeDllEntry(); + #endif + } +//#endif +} +#pragma exit BCBUninstallFastMM 0 + +#endif //PatchBCBTerminate + +#ifdef __cplusplus +} // extern "C" +#endif + +#pragma option pop + +//#endif //!_NO_VCL diff --git a/contrib/FastMM4-AVX/Compile_FastMM4_AVX512.cmd b/contrib/FastMM4-AVX/Compile_FastMM4_AVX512.cmd new file mode 100644 index 0000000..aeb09ef --- /dev/null +++ b/contrib/FastMM4-AVX/Compile_FastMM4_AVX512.cmd @@ -0,0 +1 @@ +nasm.exe -Ox -Ov -f win64 FastMM4_AVX512.asm diff --git a/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.dfm b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.dfm new file mode 100644 index 0000000..1721a67 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.dfm @@ -0,0 +1,47 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.pas b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.pas new file mode 100644 index 0000000..056db49 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/ApplicationForm.pas @@ -0,0 +1,51 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.dfm b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.dfm new file mode 100644 index 0000000..f0acf6c --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.dfm @@ -0,0 +1,54 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.pas b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.pas new file mode 100644 index 0000000..eea2d75 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DLLForm.pas @@ -0,0 +1,39 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.groupproj b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.groupproj new file mode 100644 index 0000000..c818d70 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/DynamicallyLoadedDLLDemo.groupproj @@ -0,0 +1,44 @@ + + + {39e9f19f-728b-49d7-8ea1-18ef0776485d} + + + + + + + + Default.Personality + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dpr b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dpr new file mode 100644 index 0000000..bbdee8d --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dpr @@ -0,0 +1,14 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dproj b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dproj new file mode 100644 index 0000000..b924825 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestApplication.dproj @@ -0,0 +1,71 @@ + + + {ddb60ef2-54ec-4031-ade8-28222d2e51e3} + TestApplication.dpr + Debug + AnyCPU + DCC32 + TestApplication.exe + + + 7.0 + False + False + 0 + ShareMM;RELEASE + + + 7.0 + ShareMM;DEBUG + + + Delphi.Personality + + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 7177 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + TestApplication.dpr + + + + + + + MainSource + + +
fAppMain
+ + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dpr b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dpr new file mode 100644 index 0000000..cf784d5 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dpr @@ -0,0 +1,26 @@ +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/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dproj b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dproj new file mode 100644 index 0000000..cec0812 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Dynamically Loaded DLL/TestDLL.dproj @@ -0,0 +1,71 @@ + + + {dc5ee909-443c-42e3-aed6-5b0de135122e} + TestDLL.dpr + Debug + AnyCPU + DCC32 + TestDLL.dll + + + 7.0 + False + False + 0 + ShareMM;AttemptToUseSharedMM;RELEASE + + + 7.0 + ShareMM;AttemptToUseSharedMM;DEBUG + + + Delphi.Personality + + + + False + True + False + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 7177 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + TestDLL.dpr + + + + + + + MainSource + + +
fDLLMain
+ + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.dfm b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.dfm new file mode 100644 index 0000000..962cc10 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.dfm @@ -0,0 +1,44 @@ +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/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.pas b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.pas new file mode 100644 index 0000000..b4bc95a --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/DemoForm.pas @@ -0,0 +1,76 @@ +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/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr new file mode 100644 index 0000000..5c65f80 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Replacement borlndmm DLL/FullDebugModeDemo.dpr @@ -0,0 +1,15 @@ +program FullDebugModeDemo; + +uses + ShareMem, + Forms, + DemoForm in 'DemoForm.pas' {Form1}, + FastMMDebugSupport in '..\..\Replacement BorlndMM DLL\Delphi\FastMMDebugSupport.pas'; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.dfm b/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.dfm new file mode 100644 index 0000000..a5b0ec9 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.dfm @@ -0,0 +1,28 @@ +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/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.pas b/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.pas new file mode 100644 index 0000000..a67350a --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/DemoForm.pas @@ -0,0 +1,31 @@ +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/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.dfm b/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.dfm new file mode 100644 index 0000000..f6e55c6 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.dfm @@ -0,0 +1,264 @@ +object fFastMMUsageTracker: TfFastMMUsageTracker + Left = 460 + Top = 178 + BorderIcons = [biSystemMenu] + BorderStyle = bsSingle + Caption = 'FastMM Memory Usage Tracker' + ClientHeight = 556 + ClientWidth = 553 + 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 bClose: TBitBtn + Left = 472 + Top = 524 + Width = 75 + Height = 25 + Caption = 'Close' + TabOrder = 0 + OnClick = bCloseClick + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 04000000000000010000130B0000130B00001000000000000000000000000000 + 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333 + 3333333333FFFFF3333333333999993333333333F77777FFF333333999999999 + 3333333777333777FF3333993333339993333377FF3333377FF3399993333339 + 993337777FF3333377F3393999333333993337F777FF333337FF993399933333 + 399377F3777FF333377F993339993333399377F33777FF33377F993333999333 + 399377F333777FF3377F993333399933399377F3333777FF377F993333339993 + 399377FF3333777FF7733993333339993933373FF3333777F7F3399933333399 + 99333773FF3333777733339993333339933333773FFFFFF77333333999999999 + 3333333777333777333333333999993333333333377777333333} + NumGlyphs = 2 + end + object bUpdate: TBitBtn + Left = 392 + Top = 524 + Width = 75 + Height = 25 + Caption = 'Update' + TabOrder = 1 + OnClick = bUpdateClick + Glyph.Data = { + 76010000424D7601000000000000760000002800000020000000100000000100 + 04000000000000010000120B0000120B00001000000000000000000000000000 + 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 + FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00370777033333 + 3330337F3F7F33333F3787070003333707303F737773333373F7007703333330 + 700077337F3333373777887007333337007733F773F333337733700070333333 + 077037773733333F7F37703707333300080737F373333377737F003333333307 + 78087733FFF3337FFF7F33300033330008073F3777F33F777F73073070370733 + 078073F7F7FF73F37FF7700070007037007837773777F73377FF007777700730 + 70007733FFF77F37377707700077033707307F37773F7FFF7337080777070003 + 3330737F3F7F777F333778080707770333333F7F737F3F7F3333080787070003 + 33337F73FF737773333307800077033333337337773373333333} + NumGlyphs = 2 + end + object ChkAutoUpdate: TCheckBox + Left = 280 + Top = 528 + Width = 97 + Height = 17 + Caption = 'Auto Update' + TabOrder = 2 + OnClick = ChkAutoUpdateClick + end + object pcUsageTracker: TPageControl + Left = 0 + Top = 0 + Width = 553 + Height = 521 + ActivePage = tsAllocation + Align = alTop + TabOrder = 3 + object tsAllocation: TTabSheet + Caption = 'FastMM4 Allocation' + object sgBlockStatistics: TStringGrid + Left = 4 + Top = 4 + Width = 533 + Height = 481 + DefaultColWidth = 83 + DefaultRowHeight = 17 + Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] + PopupMenu = smMM4Allocation + ScrollBars = ssVertical + TabOrder = 0 + OnDrawCell = sgBlockStatisticsDrawCell + ColWidths = ( + 83 + 104 + 106 + 106 + 108) + end + end + object tsVMGraph: TTabSheet + Caption = 'VM Graph' + ImageIndex = 1 + object Label1: TLabel + Left = 8 + Top = 440 + Width = 38 + Height = 13 + Caption = 'Address' + end + object Label2: TLabel + Left = 152 + Top = 440 + Width = 25 + Height = 13 + Caption = 'State' + end + object Label3: TLabel + Left = 8 + Top = 468 + Width = 43 + Height = 13 + Caption = 'Exe/DLL' + end + object eAddress: TEdit + Left = 60 + Top = 436 + Width = 81 + Height = 21 + Enabled = False + TabOrder = 0 + Text = '$00000000' + end + object eState: TEdit + Left = 184 + Top = 436 + Width = 105 + Height = 21 + Enabled = False + TabOrder = 1 + Text = 'Unallocated' + end + object eDLLName: TEdit + Left = 60 + Top = 464 + Width = 477 + Height = 21 + ReadOnly = True + TabOrder = 2 + end + object ChkSmallGraph: TCheckBox + Left = 304 + Top = 436 + Width = 97 + Height = 21 + Caption = 'Small Map' + Checked = True + State = cbChecked + TabOrder = 3 + OnClick = ChkSmallGraphClick + end + object dgMemoryMap: TDrawGrid + Left = 4 + Top = 4 + Width = 533 + Height = 425 + ColCount = 64 + DefaultColWidth = 8 + DefaultRowHeight = 8 + FixedCols = 0 + RowCount = 1024 + FixedRows = 0 + GridLineWidth = 0 + Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] + ScrollBars = ssVertical + TabOrder = 4 + OnDrawCell = dgMemoryMapDrawCell + OnSelectCell = dgMemoryMapSelectCell + end + end + object tsVMDump: TTabSheet + Caption = 'VM Dump' + ImageIndex = 2 + object sgVMDump: TStringGrid + Left = 4 + Top = 4 + Width = 533 + Height = 481 + DefaultColWidth = 83 + DefaultRowHeight = 17 + FixedCols = 0 + Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] + PopupMenu = smVMDump + ScrollBars = ssVertical + TabOrder = 0 + OnDrawCell = sgVMDumpDrawCell + OnMouseDown = sgVMDumpMouseDown + OnMouseUp = sgVMDumpMouseUp + ColWidths = ( + 83 + 96 + 60 + 58 + 209) + end + end + object tsGeneralInformation: TTabSheet + Caption = 'General Information' + ImageIndex = 3 + object mVMStatistics: TMemo + Left = 4 + Top = 4 + Width = 533 + Height = 481 + Font.Charset = ANSI_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Courier New' + Font.Style = [] + ParentFont = False + PopupMenu = smGeneralInformation + ReadOnly = True + ScrollBars = ssVertical + TabOrder = 0 + end + end + end + object tTimer: TTimer + Enabled = False + Interval = 2000 + OnTimer = tTimerTimer + Left = 128 + Top = 512 + end + object smVMDump: TPopupMenu + Left = 100 + Top = 512 + object miVMDumpCopyAlltoClipboard: TMenuItem + Caption = '&Copy All to Clipboard' + OnClick = miVMDumpCopyAlltoClipboardClick + end + end + object smGeneralInformation: TPopupMenu + Left = 68 + Top = 512 + object miGeneralInformationCopyAlltoClipboard: TMenuItem + Caption = '&Copy All to Clipboard' + OnClick = miGeneralInformationCopyAlltoClipboardClick + end + end + object smMM4Allocation: TPopupMenu + Left = 36 + Top = 512 + object siMM4AllocationCopyAlltoClipboard: TMenuItem + Caption = '&Copy All to Clipboard' + OnClick = siMM4AllocationCopyAlltoClipboardClick + end + end +end diff --git a/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.pas b/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.pas new file mode 100644 index 0000000..d47dfda --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/FastMMUsageTracker.pas @@ -0,0 +1,1184 @@ +(* + +Fast Memory Manager Usage Tracker 2.00 + +Description: + + - Shows FastMM4 allocation usage + + - Shows VM Memory in graphical map + - Free + - Commit + - Reserved + - EXE (Red) + - DLLs (Blue) + + - VM Dump of the whole process + (2GB standard, 3GB with the /3G switch set, and 4GB under WoW64) + + - General Information + - System memory usage + - Process memory usage + - 5 Largest contiguous free VM memory spaces + - FastMM4 summary information + +Usage: + - Add the FastMMUsageTracker unit + - Add the ShowFastMMUsageTracker procedure to an event + - FastMMUsageTracker form should not be autocreated + +Notes: + - Consider setting the base adress of your BPLs & DLLs or use Microsoft's + ReBase.exe to set third party BPLs and DLLs. Libraries that do not have to + be relocated can be shared across processes, thus conserving system + resources. + - The first of the "Largest contiguous free VM memory spaces" gives you an + indication of the largest single memory block that can be allocated. + +Change log: + + Version 2.10 (22 September 2009): + - New usage tracker implemented by Hanspeter Widmer with many new features. + (Thanks Hanspeter!); + - Colour coding of changes in the allocation map added by Murray McGowan + (red for an increase in usage, green for a decrease). (Thanks Murray!) + +*) + +unit FastMMUsageTracker; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls, Grids, Buttons, ComCtrls, Menus, FastMM4; + +type + TChunkStatusEx = ( + {Items that correspond to the same entry in TChunkStatus} + csExUnallocated, + csExAllocated, + csExReserved, + csExSysAllocated, + csExSysReserved, + {TChunkStatusEx additional detail} + csExSysExe, + csExSysDLL); + + TMemoryMapEx = array[0..65535] of TChunkStatusEx; + + TfFastMMUsageTracker = class(TForm) + tTimer: TTimer; + bClose: TBitBtn; + bUpdate: TBitBtn; + ChkAutoUpdate: TCheckBox; + smVMDump: TPopupMenu; + smMM4Allocation: TPopupMenu; + smGeneralInformation: TPopupMenu; + miVMDumpCopyAlltoClipboard: TMenuItem; + miGeneralInformationCopyAlltoClipboard: TMenuItem; + siMM4AllocationCopyAlltoClipboard: TMenuItem; + pcUsageTracker: TPageControl; + tsAllocation: TTabSheet; + tsVMGraph: TTabSheet; + tsVMDump: TTabSheet; + tsGeneralInformation: TTabSheet; + mVMStatistics: TMemo; + sgVMDump: TStringGrid; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + eAddress: TEdit; + eState: TEdit; + eDLLName: TEdit; + ChkSmallGraph: TCheckBox; + sgBlockStatistics: TStringGrid; + dgMemoryMap: TDrawGrid; + 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); + procedure bUpdateClick(Sender: TObject); + procedure ChkAutoUpdateClick(Sender: TObject); + procedure ChkSmallGraphClick(Sender: TObject); + procedure sgVMDumpMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure sgVMDumpMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure sgVMDumpDrawCell(Sender: TObject; ACol, ARow: Integer; + Rect: TRect; State: TGridDrawState); + procedure miVMDumpCopyAlltoClipboardClick(Sender: TObject); + procedure miGeneralInformationCopyAlltoClipboardClick(Sender: TObject); + procedure siMM4AllocationCopyAlltoClipboardClick(Sender: TObject); + procedure sgBlockStatisticsDrawCell(Sender: TObject; ACol, + ARow: Integer; Rect: TRect; State: TGridDrawState); + private + {The current and previous memory manager states} + FMemoryManagerState, FPrevMemoryManagerState: TMemoryManagerState; + FMemoryMapEx: TMemoryMapEx; + AddressSpacePageCount: Integer; + OR_VMDumpDownCell: TGridCoord; + procedure HeaderClicked(AGrid: TStringgrid; const ACell: TGridCoord); + procedure SortGrid(grid: TStringgrid; PB_Nummeric: Boolean; byColumn: Integer; ascending: Boolean); + procedure UpdateGraphMetrics; + public + {Refreshes the display} + procedure RefreshSnapShot; + end; + +function ShowFastMMUsageTracker: TfFastMMUsageTracker; + +implementation + +uses + Clipbrd, PsAPI; + +{$R *.dfm} + +const + SystemBasicInformation = 0; + SystemPerformanceInformation = 2; + SystemTimeInformation = 3; + + +type + {To get access to protected methods} + TLocalStringGrid = class(TStringGrid); + + TMemoryStatusEx = packed record + dwLength: DWORD; + dwMemoryLoad: DWORD; + ullTotalPhys: Int64; + ullAvailPhys: Int64; + ullTotalPageFile: Int64; + ullAvailPageFile: Int64; + ullTotalVirtual: Int64; + ullAvailVirtual: Int64; + ullAvailExtendedVirtual: Int64; + end; + PMemoryStatusEx = ^TMemoryStatusEx; + LPMEMORYSTATUSEX = PMemoryStatusEx; + + TP_GlobalMemoryStatusEx = function( + var PR_MemStatusEx: TMemoryStatusEx): LongBool; stdcall; + + TSystem_Basic_Information = packed record + dwUnknown1: DWORD; + uKeMaximumIncrement: ULONG; + uPageSize: ULONG; + uMmNumberOfPhysicalPages: ULONG; + uMmLowestPhysicalPage: ULONG; + uMmHighestPhysicalPage: ULONG; + uAllocationGranularity: ULONG; + pLowestUserAddress: Pointer; + pMmHighestUserAddress: Pointer; + uKeActiveProcessors: ULONG; + bKeNumberProcessors: Byte; + bUnknown2: Byte; + wUnknown3: Word; + end; + + TSystem_Performance_Information = packed record + liIdleTime: LARGE_INTEGER; + dwSpare: array[0..75] of DWORD; + end; + + TSystem_Time_Information = packed record + liKeBootTime: LARGE_INTEGER; + liKeSystemTime: LARGE_INTEGER; + liExpTimeZoneBias: LARGE_INTEGER; + uCurrentTimeZoneId: ULONG; + dwReserved: DWORD; + end; + + TP_NtQuerySystemInformation = function(InfoClass: DWORD; Buffer: Pointer; + BufSize: DWORD; ReturnSize: PCardinal): DWORD; stdcall; + +var + MP_GlobalMemoryStatusEx: TP_GlobalMemoryStatusEx = nil; + MP_NtQuerySystemInformation: TP_NtQuerySystemInformation = nil; + +//----------------------------------------------------------------------------- +// Various Global Procedures +//----------------------------------------------------------------------------- + +function ShowFastMMUsageTracker: TfFastMMUsageTracker; +begin + Application.CreateForm(TfFastMMUsageTracker, Result); + if Assigned(Result) then + begin + Result.RefreshSnapShot; + Result.Show; + end; +end; + +function CardinalToStringFormatted(const ACardinal: Cardinal): string; +begin + Result := FormatFloat('#,##0', ACardinal); +end; + +function Int64ToStringFormatted(const AInt64: Int64): string; +begin + Result := FormatFloat('#,##0', AInt64); +end; + +function CardinalToKStringFormatted(const ACardinal: Cardinal): string; +begin + Result := FormatFloat('#,##0', ACardinal div 1024) + 'K'; +end; + +function Int64ToKStringFormatted(const AInt64: Int64): string; +begin + Result := FormatFloat('#,##0', AInt64 div 1024) + 'K'; +end; + +procedure CopyGridContentsToClipBoard(AStringGrid: TStringGrid); +const + TAB = Chr(VK_TAB); + CRLF = #13#10; +var + LI_r, LI_c: Integer; + LS_S: string; +begin + LS_S := ''; + for LI_r := 0 to AStringGrid.RowCount - 1 do + begin + for LI_c := 0 to AStringGrid.ColCount - 1 do + begin + LS_S := LS_S + AStringGrid.Cells[LI_c, LI_r]; + if LI_c < AStringGrid.ColCount - 1 then + LS_S := LS_S + TAB; + end; + if LI_r < AStringGrid.RowCount - 1 then + LS_S := LS_S + CRLF; + end; + ClipBoard.SetTextBuf(PChar(LS_S)); +end; + +function LocSort(P1, P2: Pointer): Integer; +begin + if NativeUInt(P1) = NativeUInt(P2) then + Result := 0 + else + begin + if NativeUInt(P1) > NativeUInt(P2) then + Result := -1 + else + Result := 1; + end; +end; + +//----------------------------------------------------------------------------- +// Form TfFastMMUsageTracker +//----------------------------------------------------------------------------- + +procedure TfFastMMUsageTracker.FormCreate(Sender: TObject); +var + LR_SystemInfo: TSystemInfo; +begin + pcUsageTracker.ActivePage := tsAllocation; + GetSystemInfo(LR_SystemInfo); + {Get the number of address space pages} + if (Cardinal(LR_SystemInfo.lpMaximumApplicationAddress) and $80000000) = 0 then + AddressSpacePageCount := 32768 + else + AddressSpacePageCount := 65536; + {Update the graph metricx} + UpdateGraphMetrics; + {Set up the StringGrid columns} + with sgBlockStatistics do + begin + Cells[0, 0] := 'Block Size'; + Cells[1, 0] := '# Live Pointers'; + Cells[2, 0] := 'Live Size'; + Cells[3, 0] := 'Used Space'; + Cells[4, 0] := 'Efficiency'; + end; + with sgVMDump do + begin + Cells[0, 0] := 'VM Block'; + Cells[1, 0] := 'Size'; + Cells[2, 0] := 'Type'; + Cells[3, 0] := 'State'; + Cells[4, 0] := 'EXE/DLL'; + end; +end; + +procedure TfFastMMUsageTracker.FormClose(Sender: TObject; var Action: TCloseAction); +begin + Action := caFree; +end; + +procedure TfFastMMUsageTracker.SortGrid(grid: TStringgrid; PB_Nummeric: Boolean; byColumn: Integer; ascending: Boolean); + + function CompareNumeric(const S1, S2: string): Integer; + var + LVal1, LVal2: Integer; + begin + begin + LVal1 := StrToInt(S1); + LVal2 := StrToInt(S2); + if LVal1 = LVal2 then + begin + Result := 0; + end + else + begin + if LVal1 > LVal2 then + Result := 1 + else + Result := -1; + end; + end; + end; + + procedure ExchangeGridRows(i, j: Integer); + var + k: Integer; + begin + for k := 0 to Grid.ColCount - 1 do + Grid.Cols[k].Exchange(i, j); + end; + + procedure QuickSortNummeric(L, R: Integer); + var + I, J: Integer; + P: string; + begin + repeat + I := L; + J := R; + P := Grid.Cells[byColumn, (L + R) shr 1]; + repeat + while CompareNumeric(Grid.Cells[byColumn, I], P) < 0 do + Inc(I); + while CompareNumeric(Grid.Cells[byColumn, J], P) > 0 do + Dec(J); + if I <= J then + begin + if I <> J then + ExchangeGridRows(I, J); + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSortNummeric(L, J); + L := I; + until I >= R; + end; + + procedure QuickSortString(L, R: Integer); + var + I, J: Integer; + P: string; + begin + repeat + I := L; + J := R; + P := Grid.Cells[byColumn, (L + R) shr 1]; + repeat + while CompareText(Grid.Cells[byColumn, I], P) < 0 do + Inc(I); + while CompareText(Grid.Cells[byColumn, J], P) > 0 do + Dec(J); + if I <= J then + begin + if I <> J then + ExchangeGridRows(I, J); + Inc(I); + Dec(J); + end; + until I > J; + if L < J then + QuickSortString(L, J); + L := I; + until I >= R; + end; + + procedure InvertGrid; + var + i, j: Integer; + begin + i := Grid.Fixedrows; + j := Grid.Rowcount - 1; + while i < j do + begin + ExchangeGridRows(I, J); + Inc(i); + Dec(j); + end; + end; + +begin + Screen.Cursor := crHourglass; + Grid.Perform(WM_SETREDRAW, 0, 0); + try + if PB_Nummeric then + QuickSortNummeric(Grid.FixedRows, Grid.Rowcount - 1) + else + QuickSortString(Grid.FixedRows, Grid.Rowcount - 1); + if not Ascending then + InvertGrid; + finally + Grid.Perform(WM_SETREDRAW, 1, 0); + Grid.Refresh; + Screen.Cursor := crDefault; + end; +end; + + +procedure TfFastMMUsageTracker.HeaderClicked(AGrid: TStringgrid; const ACell: TGridCoord); +var + i: Integer; + LNumericSort: Boolean; +begin + // The header cell stores a flag in the Objects property that signals the + // current sort order of the grid column. A value of 0 shows no sort marker, + // 1 means sorted ascending, -1 sorted descending + // clear markers + for i := AGrid.FixedCols to AGrid.ColCount - 1 do + begin + if Assigned(AGrid.Objects[i, 0]) and (i <> ACell.x) then + begin + AGrid.Objects[i, 0] := nil; + TLocalStringGrid(AGrid).InvalidateCell(i, 0); + end; + end; + // Sort grid on new column. If grid is currently sorted ascending on this + // column we invert the sort direction, otherwise we sort it ascending. + if ACell.X = 1 then + LNumericSort := True + else + LNumericSort := False; + if Integer(AGrid.Objects[ACell.x, ACell.y]) = 1 then + begin + SortGrid(AGrid, LNumericSort, ACell.x, False); + AGrid.Objects[ACell.x, 0] := Pointer(-1); + end + else + begin + SortGrid(AGrid, LNumericSort, ACell.x, True); + AGrid.Objects[ACell.x, 0] := Pointer(1); + end; + TLocalStringGrid(AGrid).InvalidateCell(ACell.x, ACell.y); +end; + +procedure TfFastMMUsageTracker.UpdateGraphMetrics; +begin + if ChkSmallGraph.Checked then + begin + dgMemoryMap.DefaultColWidth := 4; + dgMemoryMap.ColCount := 128; + end + else + begin + dgMemoryMap.DefaultColWidth := 8; + dgMemoryMap.ColCount := 64; + end; + dgMemoryMap.DefaultRowHeight := dgMemoryMap.DefaultColWidth; + dgMemoryMap.RowCount := AddressSpacePageCount div dgMemoryMap.ColCount; +end; + +procedure TfFastMMUsageTracker.RefreshSnapShot; +var + LP_FreeVMList: TList; + LU_MEM_FREE: SIZE_T; + LU_MEM_COMMIT: SIZE_T; + LU_MEM_RESERVE: SIZE_T; + LAllocatedSize, LTotalBlocks, LTotalAllocated, LTotalReserved, + LPrevAllocatedSize, LPrevTotalBlocks, LPrevTotalAllocated, LPrevTotalReserved: NativeUInt; + + procedure UpdateVMGraph(var AMemoryMap: TMemoryMapEx); + var + LInd, LIndTop, I1: Integer; + LChunkState: TChunkStatusEx; + LMBI: TMemoryBasicInformation; + LA_Char: array[0..MAX_PATH] of Char; + begin + LInd := 0; + repeat + {If the chunk is not allocated by this MM, what is its status?} + if AMemoryMap[LInd] = csExSysAllocated 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 + begin + if (GetModuleFileName(DWord(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then + begin + if DWord(LMBI.AllocationBase) = SysInit.HInstance then + LChunkState := csExSysExe + else + LChunkState := csExSysDLL; + end + else + begin + LChunkState := csExSysAllocated; + end; + if LMBI.RegionSize > 65536 then + begin + LIndTop := (Cardinal(LMBI.BaseAddress) + Cardinal(LMBI.RegionSize)) div 65536; + // Fill up multiple tables + for I1 := LInd to LIndTop do + AMemoryMap[I1] := LChunkState; + LInd := LIndTop; + end + else + begin + AMemoryMap[LInd] := LChunkState; + end; + end + end; + Inc(LInd); + until LInd >= AddressSpacePageCount; + end; + + procedure UpdateVMDump; + var + LP_Base: PByte; + LR_Info: TMemoryBasicInformation; + LU_rv: SIZE_T; + LI_I: Integer; + LA_Char: array[0..MAX_PATH] of Char; + begin + LP_Base := nil; + LU_rv := VirtualQuery(LP_Base, LR_Info, sizeof(LR_Info)); + LI_I := 1; + while LU_rv = sizeof(LR_Info) do + begin + with sgVMDump do + begin + Cells[0, LI_I] := IntToHex(Integer(LR_Info.BaseAddress), 8); + Cells[1, LI_I] := IntToStr(LR_Info.RegionSize); + Cells[3, LI_I] := IntToHex(Integer(LR_Info.Protect), 8); + case LR_Info.State of + + MEM_Commit: + begin + LU_MEM_COMMIT := LU_MEM_COMMIT + LR_Info.RegionSize; + if (GetModuleFileName(dword(LR_Info.AllocationBase), LA_Char, MAX_PATH) <> 0) then + begin + if DWord(LR_Info.AllocationBase) = SysInit.HInstance then + Cells[2, LI_I] := 'Exe' + else + Cells[2, LI_I] := 'DLL'; + Cells[4, LI_I] := ExtractFileName(LA_Char); + end + else + begin + Cells[4, LI_I] := ''; + Cells[2, LI_I] := 'Commited'; + end; + end; + + MEM_RESERVE: + begin + LU_MEM_RESERVE := LU_MEM_RESERVE + LR_Info.RegionSize; + Cells[2, LI_I] := 'Reserved'; + Cells[4, LI_I] := ''; + end; + + MEM_FREE: + begin + LP_FreeVMList.Add(Pointer(LR_Info.RegionSize)); + LU_MEM_FREE := LU_MEM_FREE + Lr_Info.RegionSize; + Cells[2, LI_I] := 'Free'; + Cells[4, LI_I] := ''; + end; + end; + + Inc(LP_Base, LR_Info.RegionSize); + LU_rv := VirtualQuery(LP_Base, LR_Info, sizeof(LR_Info)); + Inc(LI_I); + end; + end; + + sgVMDump.RowCount := LI_I; + end; + + procedure UpdateFastMM4Data; + var + LInd: Integer; + LU_StateLength: Cardinal; + LPrevSBState, LSBState: ^TSmallBlockTypeState; + + procedure UpdateBlockStatistics(c, r, current, prev: Integer); + var + s : string; + begin + s := IntToStr(current); + if current > prev then + s := s + ' (+' + IntToStr(current - prev) + ')' + else if current < prev then + s := s + ' (-' + IntToStr(prev - current) + ')'; + sgBlockStatistics.Cells[c, r] := s; + sgBlockStatistics.Objects[c, r] := Pointer(current - prev); + end; + + begin + LU_StateLength := Length(FMemoryManagerState.SmallBlockTypeStates); + {Set up the row count} + sgBlockStatistics.RowCount := LU_StateLength + 4; + sgBlockStatistics.Cells[0, LU_StateLength + 1] := 'Medium Blocks'; + sgBlockStatistics.Cells[0, LU_StateLength + 2] := 'Large Blocks'; + sgBlockStatistics.Cells[0, LU_StateLength + 3] := 'Overall'; + 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; + {Set the texts inside the results string grid} + for LInd := 0 to High(FMemoryManagerState.SmallBlockTypeStates) do + begin + LPrevSBState := @FPrevMemoryManagerState.SmallBlockTypeStates[LInd]; + LSBState := @FMemoryManagerState.SmallBlockTypeStates[LInd]; + UpdateBlockStatistics(1, LInd + 1, LSBState.AllocatedBlockCount, LPrevSBState.AllocatedBlockCount); + Inc(LTotalBlocks, LSBState.AllocatedBlockCount); + Inc(LPrevTotalBlocks, LPrevSBState.AllocatedBlockCount); + LAllocatedSize := LSBState.AllocatedBlockCount * LSBState.UseableBlockSize; + LPrevAllocatedSize := LPrevSBState.AllocatedBlockCount * LPrevSBState.UseableBlockSize; + UpdateBlockStatistics(2, LInd + 1, LAllocatedSize, LPrevAllocatedSize); + Inc(LTotalAllocated, LAllocatedSize); + Inc(LPrevTotalAllocated, LPrevAllocatedSize); + UpdateBlockStatistics(3, LInd + 1, LSBState.ReservedAddressSpace, LPrevSBState.ReservedAddressSpace); + Inc(LTotalReserved, LSBState.ReservedAddressSpace); + Inc(LPrevTotalReserved, LPrevSBState.ReservedAddressSpace); + if LSBState.ReservedAddressSpace > 0 then + sgBlockStatistics.Cells[4, LInd + 1] := FormatFloat('0.##%', LAllocatedSize / LSBState.ReservedAddressSpace * 100) + else + sgBlockStatistics.Cells[4, LInd + 1] := 'N/A'; + end; + {-----------Medium blocks---------} + LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 1; + UpdateBlockStatistics(1, LInd, FMemoryManagerState.AllocatedMediumBlockCount, FPrevMemoryManagerState.AllocatedMediumBlockCount); + Inc(LTotalBlocks, FMemoryManagerState.AllocatedMediumBlockCount); + Inc(LPrevTotalBlocks, FPrevMemoryManagerState.AllocatedMediumBlockCount); + UpdateBlockStatistics(2, LInd, FMemoryManagerState.TotalAllocatedMediumBlockSize, FPrevMemoryManagerState.TotalAllocatedMediumBlockSize); + Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedMediumBlockSize); + Inc(LPrevTotalAllocated, FPrevMemoryManagerState.TotalAllocatedMediumBlockSize); + UpdateBlockStatistics(3, LInd, FMemoryManagerState.ReservedMediumBlockAddressSpace, FPrevMemoryManagerState.ReservedMediumBlockAddressSpace); + Inc(LTotalReserved, FMemoryManagerState.ReservedMediumBlockAddressSpace); + Inc(LPrevTotalReserved, FPrevMemoryManagerState.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; + UpdateBlockStatistics(1, LInd, FMemoryManagerState.AllocatedLargeBlockCount, FPrevMemoryManagerState.AllocatedLargeBlockCount); + Inc(LTotalBlocks, FMemoryManagerState.AllocatedLargeBlockCount); + Inc(LPrevTotalBlocks, FPrevMemoryManagerState.AllocatedLargeBlockCount); + UpdateBlockStatistics(2, LInd, FMemoryManagerState.TotalAllocatedLargeBlockSize, FPrevMemoryManagerState.TotalAllocatedLargeBlockSize); + Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedLargeBlockSize); + Inc(LPrevTotalAllocated, FPrevMemoryManagerState.TotalAllocatedLargeBlockSize); + UpdateBlockStatistics(3, LInd, FMemoryManagerState.ReservedLargeBlockAddressSpace, FPrevMemoryManagerState.ReservedLargeBlockAddressSpace); + Inc(LTotalReserved, FMemoryManagerState.ReservedLargeBlockAddressSpace); + Inc(LPrevTotalReserved, FPrevMemoryManagerState.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; + UpdateBlockStatistics(1, Lind, LTotalBlocks, LPrevTotalBlocks); + UpdateBlockStatistics(2, Lind, LTotalAllocated, LPrevTotalAllocated); + UpdateBlockStatistics(3, Lind, LTotalReserved, LPrevTotalReserved); + if LTotalReserved > 0 then + sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', LTotalAllocated / LTotalReserved * 100) + else + sgBlockStatistics.Cells[4, LInd] := 'N/A'; + end; + + procedure UpdateStatisticsData; + const + CI_MaxFreeBlocksList = 9; + + var + LR_SystemInfo: TSystemInfo; + LR_GlobalMemoryStatus: TMemoryStatus; + LR_GlobalMemoryStatusEx: TMemoryStatusEx; + LR_ProcessMemoryCounters: TProcessMemoryCounters; + LR_SysBaseInfo: TSystem_Basic_Information; + LU_MinQuota: {$if CompilerVersion >= 23}NativeUInt{$else}Cardinal{$ifend}; + LU_MaxQuota: {$if CompilerVersion >= 23}NativeUInt{$else}Cardinal{$ifend}; + LI_I: Integer; + LI_Max: Integer; + begin + mVMStatistics.Lines.BeginUpdate; + try + mVMStatistics.Clear; + + LU_MinQuota := 0; + LU_MaxQuota := 0; + + if Assigned(MP_GlobalMemoryStatusEx) then + begin + ZeroMemory(@LR_GlobalMemoryStatusEx, SizeOf(TMemoryStatusEx)); + LR_GlobalMemoryStatusEx.dwLength := SizeOf(TMemoryStatusEx); + + if not MP_GlobalMemoryStatusEx(LR_GlobalMemoryStatusEx) then + begin + mVMStatistics.Lines.Add('GlobalMemoryStatusEx err: ' + SysErrorMessage(GetLastError)); + end; + end + else + begin + LR_GlobalMemoryStatus.dwLength := SizeOf(TMemoryStatus); + GlobalMemoryStatus(LR_GlobalMemoryStatus); + end; + + LP_FreeVMList.SortList(LocSort); + + GetProcessWorkingSetSize(GetCurrentProcess, LU_MinQuota, LU_MaxQuota); + GetSystemInfo(LR_SystemInfo); + + with mVMStatistics.Lines do + begin + Add('System Info:'); + Add('------------'); + + Add('Processor Count = ' + IntToStr(LR_SystemInfo.dwNumberOfProcessors)); + Add('Allocation Granularity = ' + IntToStr(LR_SystemInfo.dwAllocationGranularity)); + + if Assigned(MP_GlobalMemoryStatusEx) then + begin + with LR_GlobalMemoryStatusEx do + begin + Add('Available Physical Memory = ' + Int64ToKStringFormatted(ullAvailPhys)); + Add('Total Physical Memory = ' + Int64ToKStringFormatted(ullTotalPhys)); + Add('Available Virtual Memory = ' + Int64ToKStringFormatted(ullAvailVirtual)); + Add('Total Virtual Memory = ' + Int64ToKStringFormatted(ullTotalVirtual)); + Add('Total Virtual Extended Memory = ' + Int64ToKStringFormatted(ullAvailExtendedVirtual)); + end; + end + + else + begin + with LR_GlobalMemoryStatus do + begin + Add('Available Physical Memory = ' + Int64ToKStringFormatted(dwAvailPhys)); + Add('Total Physical Memory = ' + Int64ToKStringFormatted(dwTotalPhys)); + Add('Available Virtual Memory = ' + Int64ToKStringFormatted(dwAvailVirtual)); + Add('Total Virtual Memory = ' + Int64ToKStringFormatted(dwTotalVirtual)); + end; + end; + + if Assigned(MP_NtQuerySystemInformation) then + begin + if MP_NtQuerySystemInformation(SystemBasicInformation, @LR_SysBaseInfo, SizeOf(LR_SysBaseInfo), nil) = 0 then + begin + with LR_SysBaseInfo do begin + Add('Maximum Increment = ' + CardinalToKStringFormatted(uKeMaximumIncrement)); + Add('Page Size = ' + CardinalToKStringFormatted(uPageSize)); + Add('Number of Physical Pages = ' + CardinalToKStringFormatted(uMmNumberOfPhysicalPages)); + Add('Lowest Physical Page = ' + CardinalToStringFormatted(uMmLowestPhysicalPage)); + Add('Highest Physical Page = ' + CardinalToKStringFormatted(uMmHighestPhysicalPage)); + end; + end; + end; + + // same as GetProcessMemoryInfo & NtQuerySystemInformation (SystemBasicInformation + + // The working set is the amount of memory physically mapped to the process context at a given + // time. Memory in the paged pool is system memory that can be transferred to the paging file + // on disk (paged) when it is not being used. Memory in the nonpaged pool is system memory + // that cannot be paged to disk as long as the corresponding objects are allocated. The pagefile + // usage represents how much memory is set aside for the process in the system paging file. + // When memory usage is too high, the virtual memory manager pages selected memory to disk. + // When a thread needs a page that is not in memory, the memory manager reloads it from the + // paging file. + + + if GetProcessMemoryInfo(GetCurrentProcess, @LR_ProcessMemoryCounters, SizeOf(LR_ProcessMemoryCounters)) then + begin + with LR_ProcessMemoryCounters do + begin + Add('Page Fault Count = ' + CardinalToKStringFormatted(PageFaultCount)); + Add('Peak Working Set Size = ' + Int64ToKStringFormatted(PeakWorkingSetSize)); + Add('Working Set Size = ' + Int64ToKStringFormatted(WorkingSetSize)); + Add('Quota Peak Paged Pool Usage = ' + Int64ToKStringFormatted(QuotaPeakPagedPoolUsage)); + Add('Quota Paged Pool Usage = ' + Int64ToKStringFormatted(QuotaPagedPoolUsage)); + Add('Quota Peak Non-Paged Pool Usage = ' + Int64ToKStringFormatted(QuotaPeakNonPagedPoolUsage)); + Add('Quota Non-Paged Pool Usage = ' + Int64ToKStringFormatted(QuotaNonPagedPoolUsage)); + Add('Pagefile Usage = ' + Int64ToKStringFormatted(PagefileUsage)); + Add('Peak Pagefile Usage = ' + Int64ToKStringFormatted(PeakPagefileUsage)); + end; + end; + + Add(''); + Add('Process Info: PID (' + IntToStr(GetCurrentProcessId) + ')'); + Add('------------------------'); + Add('Minimum Address = ' + Int64ToKStringFormatted(NativeUInt(LR_SystemInfo.lpMinimumApplicationAddress))); + Add('Maximum VM Address = ' + Int64ToKStringFormatted(NativeUInt(LR_SystemInfo.lpMaximumApplicationAddress))); + Add('Page Protection & Commit Size = ' + IntToStr(LR_SystemInfo.dWPageSize)); + Add(''); + Add('Quota info:'); + Add('-----------'); + Add('Minimum Quota = ' + Int64ToKStringFormatted(LU_MinQuota)); + Add('Maximum Quota = ' + Int64ToKStringFormatted(LU_MaxQuota)); + Add(''); + Add('VM Info:'); + Add('--------'); + Add('Total Free = ' + Int64ToKStringFormatted(LU_MEM_FREE)); + Add('Total Reserve = ' + Int64ToKStringFormatted(LU_MEM_RESERVE)); + Add('Total Commit = ' + Int64ToKStringFormatted(LU_MEM_COMMIT)); + + if LP_FreeVMList.Count > CI_MaxFreeBlocksList then + LI_Max := CI_MaxFreeBlocksList - 1 + else + LI_Max := LP_FreeVMList.Count - 1; + + for LI_I := 0 to LI_Max do + begin + Add('Largest Free Block ' + IntToStr(LI_I + 1) + '. = ' + Int64ToKStringFormatted(NativeUInt(LP_FreeVMList.List[LI_I]))); + end; + + Add(''); + Add('FastMM4 Info:'); + Add('-------------'); + Add('Total Blocks = ' + Int64ToKStringFormatted(LTotalBlocks)); + Add('Total Allocated = ' + Int64ToKStringFormatted(LTotalAllocated)); + Add('Total Reserved = ' + Int64ToKStringFormatted(LTotalReserved)); + end; + + finally + mVMStatistics.Lines.EndUpdate; + end; + end; + +var + Save_Cursor: TCursor; +begin + if SizeOf(TMemoryMap) <> SizeOf(TMemoryMapEx) then + begin + Showmessage('Internal implementation error'); + Exit; + end; + + LU_MEM_FREE := 0; + LU_MEM_COMMIT := 0; + LU_MEM_RESERVE := 0; + + LTotalBlocks := 0; + LTotalAllocated := 0; + LTotalReserved := 0; + + LPrevTotalBlocks := 0; + LPrevTotalAllocated := 0; + LPrevTotalReserved := 0; + + // Set hourglass cursor + Save_Cursor := Screen.Cursor; + Screen.Cursor := crHourGlass; + LP_FreeVMList := TList.Create; + try + // retrieve FastMM4 info + + GetMemoryManagerState(FMemoryManagerState); + GetMemoryMap(TMemoryMap(FMemoryMapEx)); + + // Update FastMM4 Graph with EXE & DLL locations + UpdateVMGraph(FMemoryMapEx); + + // VM dump + UpdateVMDump; + + // FastMM4 data + UpdateFastMM4Data; + + // General Information + UpdateStatisticsData; + + // Screen updates + dgMemoryMap.Invalidate; + + FPrevMemoryManagerState := FMemoryManagerState; + finally + FreeAndNil(LP_FreeVMList); + Screen.Cursor := Save_Cursor; + end; +end; + +procedure TfFastMMUsageTracker.sgBlockStatisticsDrawCell(Sender: TObject; + ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); +var + d: integer; + y: integer; + s: string; + LOldColour, LColour: TColor; +begin + d := Integer(sgBlockStatistics.Objects[ACol, ARow]); + if d <> 0 then + begin + LOldColour := sgBlockStatistics.Canvas.Brush.Color; + if d < 0 then + LColour := clLime + else + LColour := clRed; + sgBlockStatistics.Canvas.Brush.Color := LColour; + sgBlockStatistics.Canvas.Font.Color := clWindowText; + s := sgBlockStatistics.Cells[ACol, ARow]; + y := sgBlockStatistics.Canvas.TextHeight(s); + y := ((Rect.Bottom - Rect.Top) - y) div 2; + sgBlockStatistics.Canvas.TextRect(Rect, Rect.Left + 2, Rect.top + y, s); + sgBlockStatistics.Canvas.Brush.Color := LOldColour; + end; +end; + +procedure TfFastMMUsageTracker.tTimerTimer(Sender: TObject); +begin + tTimer.Enabled := False; + try + RefreshSnapShot; + finally + tTimer.Enabled := True; + end; +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 FMemoryMapEx[LChunkIndex] of + + csExAllocated: + begin + LChunkColour := $9090FF; + end; + + csExReserved: + begin + LChunkColour := $90F090; + end; + + csExSysAllocated: + begin + LChunkColour := $707070; + end; + + csExSysExe: + begin + LChunkColour := clRed; + end; + + csExSysDLL: + begin + LChunkColour := clBlue; + end; + + csExSysReserved: + begin + LChunkColour := $C0C0C0; + end + + else + begin + {ExUnallocated} + LChunkColour := $FFFFFF; + end; + end; + + {Draw the chunk background} + dgMemoryMap.Canvas.Brush.Color := LChunkColour; + + if State = [] then + dgMemoryMap.Canvas.FillRect(Rect) + else + dgMemoryMap.Canvas.Rectangle(Rect); +end; + +procedure TfFastMMUsageTracker.dgMemoryMapSelectCell(Sender: TObject; ACol, + ARow: Integer; var CanSelect: Boolean); +var + LChunkIndex: Cardinal; + LMBI: TMemoryBasicInformation; + LA_Char: array[0..MAX_PATH] of char; +begin + eDLLName.Text := ''; + LChunkIndex := ARow * dgMemoryMap.ColCount + ACol; + eAddress.Text := Format('$%0.8x', [LChunkIndex shl 16]); + + case FMemoryMapEx[LChunkIndex] of + + csExAllocated: + begin + eState.Text := 'FastMM Allocated'; + end; + + csExReserved: + begin + eState.Text := 'FastMM Reserved'; + end; + + csExSysAllocated: + begin + eState.Text := 'System Allocated'; + end; + + csExSysExe: + begin + eState.Text := 'System Exe'; + VirtualQuery(Pointer(LChunkIndex shl 16), LMBI, SizeOf(LMBI)); + if (GetModuleFileName(dword(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then + begin + eDLLName.Text := LA_Char; + end; + end; + + csExSysDLL: + begin + eState.Text := 'System/User DLL'; + VirtualQuery(Pointer(LChunkIndex shl 16), LMBI, SizeOf(LMBI)); + if (GetModuleFileName(dword(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then + begin + eDLLName.Text := LA_Char; + end; + end; + + csExSysReserved: + begin + eState.Text := 'System Reserved'; + end + + else + begin + {ExUnallocated} + eState.Text := 'Free'; + end; + end; +end; + +procedure TfFastMMUsageTracker.bUpdateClick(Sender: TObject); +begin + RefreshSnapShot; +end; + +procedure TfFastMMUsageTracker.ChkAutoUpdateClick(Sender: TObject); +begin + tTimer.Enabled := ChkAutoUpdate.Checked; +end; + +procedure TfFastMMUsageTracker.ChkSmallGraphClick(Sender: TObject); +begin + UpdateGraphMetrics; + dgMemoryMap.Invalidate; + dgMemoryMap.SetFocus; +end; + +procedure TfFastMMUsageTracker.sgVMDumpMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + if (Button = mbLeft) and (Shift = [ssLeft]) then + begin + (Sender as TStringgrid).MouseToCell(X, Y, OR_VMDumpDownCell.X, OR_VMDumpDownCell.Y); + end + else + begin + OR_VMDumpDownCell.X := 0; + OR_VMDumpDownCell.Y := 0; + end; +end; + +procedure TfFastMMUsageTracker.sgVMDumpMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + p: TGridCoord; + LGrid: TStringgrid; +begin + LGrid := Sender as TStringGrid; + if (Button = mbLeft) and (Shift = []) then + begin + LGrid.MouseToCell(X, Y, p.X, p.Y); + if CompareMem(@p, @OR_VMDumpDownCell, sizeof(p)) + and (p.Y < LGrid.FixedRows) + and (p.X >= LGrid.FixedCols) then + begin + HeaderClicked(LGrid, p); + end; + end; + OR_VMDumpDownCell.X := 0; + OR_VMDumpDownCell.Y := 0; +end; + +procedure TfFastMMUsageTracker.sgVMDumpDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); +var + LGrid: TStringgrid; + LMarker: Char; +begin + LGrid := Sender as TStringgrid; + // paint the sort marker on header columns + if (ACol >= LGrid.FixedCols) and (aRow = 0) then + begin + if Assigned(LGrid.Objects[aCol, aRow]) then + begin + if Integer(LGrid.Objects[aCol, aRow]) > 0 then + LMarker := 't' // up wedge in Marlett font + else + LMarker := 'u'; // down wedge in Marlett font + with LGrid.canvas do + begin + Font.Name := 'Marlett'; + Font.Charset := SYMBOL_CHARSET; + Font.Size := 12; + TextOut(Rect.Right - TextWidth(LMarker), Rect.Top, LMarker); + Font := LGrid.font; + end; + end; + end; +end; + +procedure TfFastMMUsageTracker.siMM4AllocationCopyAlltoClipboardClick(Sender: TObject); +begin + CopyGridContentsToClipBoard(sgBlockStatistics); +end; + +procedure TfFastMMUsageTracker.miVMDumpCopyAlltoClipboardClick(Sender: TObject); +begin + CopyGridContentsToClipBoard(sgVMDump); +end; + +procedure TfFastMMUsageTracker.miGeneralInformationCopyAlltoClipboardClick(Sender: TObject); +begin + with mVMStatistics do + begin + Lines.BeginUpdate; + try + SelectAll; + CopyToClipboard; + SelStart := 0; + finally + Lines.EndUpdate; + end; + end; +end; + +procedure ModuleInit; +begin + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + MP_GlobalMemoryStatusEx := TP_GlobalMemoryStatusEx( + GetProcAddress(GetModuleHandle(kernel32), 'GlobalMemoryStatusEx')); + MP_NtQuerySystemInformation := TP_NtQuerySystemInformation( + GetProcAddress(GetModuleHandle('ntdll.dll'), 'NtQuerySystemInformation')); + end; +end; + +initialization + ModuleInit; + +end. diff --git a/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dpr b/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dpr new file mode 100644 index 0000000..e6bf4ef --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dpr @@ -0,0 +1,17 @@ +program UsageTrackerDemo; + +uses + FastMM4, + Forms, + DemoForm in 'DemoForm.pas' {fDemo}; + +{$R *.res} + +{Enable large address space support for this demo} +{$SetPEFlags $20} + +begin + Application.Initialize; + Application.CreateForm(TfDemo, fDemo); + Application.Run; +end. diff --git a/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dproj b/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dproj new file mode 100644 index 0000000..28647e6 --- /dev/null +++ b/contrib/FastMM4-AVX/Demos/Usage Tracker/UsageTrackerDemo.dproj @@ -0,0 +1,69 @@ + + + {2d29cca4-0633-47dd-b826-c21a24d53d83} + UsageTrackerDemo.dpr + Debug + AnyCPU + DCC32 + UsageTrackerDemo.exe + + + 7.0 + False + False + 0 + RELEASE + ..\.. + + + 7.0 + DEBUG + ..\.. + + + Delphi.Personality + VCLApplication + +FalseTrueFalseFalseFalse1000FalseFalseFalseFalseFalse717712521.0.0.01.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Microsoft Office XP Sample Automation Server Wrapper Components + Microsoft Office 2000 Sample Automation Server Wrapper Components + UsageTrackerDemo.dpr + + + + + MainSource + + +
fDemo
+ + + diff --git a/contrib/FastMM4-AVX/FastMM4.pas b/contrib/FastMM4-AVX/FastMM4.pas new file mode 100644 index 0000000..bfa8185 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4.pas @@ -0,0 +1,20067 @@ +(* + +FastMM4-AVX (efficient synchronization and AVX1/AVX2/AVX512/ERMS/FSRM support for FastMM4) + - Copyright (C) 2017-2020 Ritlabs, SRL. All rights reserved. + - Copyright (C) 2020-2021 Maxim Masiutin. All rights reserved. + +Written by Maxim Masiutin + +Version 1.0.6 + +This is a fork of the "Fast Memory Manager" (FastMM) v4.993 by Pierre le Riche +(see below for the original FastMM4 description) + +What was added to FastMM4-AVX in comparison to the original FastMM4: + + - Efficient synchronization + - improved synchronization between the threads; proper synchronization + techniques are used depending on context and availability, i.e., spin-wait + loops, SwitchToThread, critical sections, etc.; + - used the "test, test-and-set" technique for the spin-wait loops; this + technique is recommended by Intel (see Section 11.4.3 "Optimization with + Spin-Locks" of the Intel 64 and IA-32 Architectures Optimization Reference + Manual) to determine the availability of the synchronization variable; + according to this technique, the first "test" is done via the normal + (non-locking) memory load to prevent excessive bus locking on each + iteration of the spin-wait loop; if the variable is available upon + the normal memory load of the first step ("test"), proceed to the + second step ("test-and-set") which is done via the bus-locking atomic + "xchg" instruction; however, this two-steps approach of using "test" before + "test-and-set" can increase the cost for the un-contended case comparing + to just single-step "test-and-set", this may explain why the speed benefits + of the FastMM4-AVX are more pronounced when the memory manager is called + from multiple threads in parallel, while in single-threaded use scenario + there may be no benefit compared to the original FastMM4; + - the number of iterations of "pause"-based spin-wait loops is 5000, + before relinquishing to SwitchToThread(); + - see https://stackoverflow.com/a/44916975 for more details on the + implementation of the "pause"-based spin-wait loops; + - using normal memory store to release a lock: + FastMM4-AVX uses normal memory store, i.e., the "mov" instruction, rather + then the bus-locking "xchg" instruction to write into the synchronization + variable (LockByte) to "release a lock" on a data structure, + see https://stackoverflow.com/a/44959764 + for discussion on releasing a lock; + you man define "InterlockedRelease" to get the old behavior of the original + FastMM4. + - implemented dedicated lock and unlock procedures that operate with + synchronization variables (LockByte); + before that, locking operations were scattered throughout the code; + now the locking functions have meaningful names: + AcquireLockByte and ReleaseLockByte; + the values of the lock byte are now checked for validity when + FullDebugMode or DEBUG is defined, to detect cases when the same lock is + released twice, and other improper use of the lock bytes; + - added compile-time options "SmallBlocksLockedCriticalSection", + "MediumBlocksLockedCriticalSection" and "LargeBlocksLockedCriticalSection" + which are set by default (inside the FastMM4Options.inc file) as + conditional defines. If you undefine these options, you will get the + old locking mechanism of the original FastMM4 based on loops of Sleep() or + SwitchToThread(). + + - AVX, AVX2 or AVX512 instructions for faster memory copy + - if the CPU supports AVX or AVX2, use the 32-byte YMM registers + for faster memory copy, and if the CPU supports AVX-512, + use the 64-byte ZMM registers for even faster memory copy; + - please note that the effect of using AVX instruction in speed improvement is + negligible, compared to the effect brought by efficient synchronization; + sometimes AVX instructions can even slow down the program because of AVX-SSE + transition penalties and reduced CPU frequency caused by AVX-512 + instructions in some processors; use DisableAVX to turn AVX off completely + or use DisableAVX1/DisableAVX2/DisableAVX512 to disable separately certain + AVX-related instruction set from being compiled); + - if EnableAVX is defined, all memory blocks are aligned by 32 bytes, but + you can also use Align32Bytes define without AVX; please note that the memory + overhead is higher when the blocks are aligned by 32 bytes, because some + memory is lost by padding; however, if your CPU supports + "Fast Short REP MOVSB" (Ice Lake or newer), you can disable AVX, and align + by just 8 bytes, and this may even be faster because less memory is wasted + on alignment; + - with AVX, memory copy is secure - all XMM/YMM/ZMM registers used to copy + memory are cleared by vxorps/vpxor, so the leftovers of the copied memory + are not exposed in the XMM/YMM/ZMM registers; + - the code attempts to properly handle AVX-SSE transitions to not incur the + transition penalties, only call vzeroupper under AVX1, but not under AVX2 + since it slows down subsequent SSE code under Skylake / Kaby Lake; + - on AVX-512, writing to xmm16-xmm31 registers will not affect the turbo + clocks, and will not impose AVX-SSE transition penalties; therefore, when we + have AVX-512, we now only use x(y/z)mm16-31 registers. + + - Speed improvements due to code optimization and proper techniques + - if the CPU supports Enhanced REP MOVSB/STOSB (ERMS), use this feature + for faster memory copy (under 32 bit or 64-bit) (see the EnableERMS define, + on by default, use DisableERMS to turn it off); + - if the CPU supports Fast Short REP MOVSB (FSRM), uses this feature instead + of AVX; + - branch target alignment in assembly routines is only used when + EnableAsmCodeAlign is defined; Delphi incorrectly encodes conditional + jumps, i.e., use long, 6-byte instructions instead of just short, 2-byte, + and this may affect branch prediction, so the benefits of branch target + alignment may not outweigh the disadvantage of affected branch prediction, + see https://stackoverflow.com/q/45112065 + - compare instructions + conditional jump instructions are put together + to allow macro-op fusion (which happens since Core2 processors, when + the first instruction is a CMP or TEST instruction and the second + instruction is a conditional jump instruction); + - multiplication and division by a constant, which is a power of 2 + replaced to shl/shr, because Delphi64 compiler doesn't replace such + multiplications and divisions to shl/shr processor instructions, + and, according to the Intel Optimization Reference Manual, shl/shr is + faster than imul/idiv, at least for some processors. + + - Safer, cleaner code with stricter type adherence and better compatibility + - names assigned to some constants that used to be "magic constants", + i.e., unnamed numerical constants - plenty of them were present + throughout the whole code; + - removed some typecasts; the code is stricter to let the compiler + do the job, check everything and mitigate probable error. You can + even compile the code with "integer overflow checking" and + "range checking", as well as with "typed @ operator" - for safer + code. Also added round bracket in the places where the typed @ operator + was used, to better emphasize on who's address is taken; + - the compiler environment is more flexible now: you can now compile FastMM4 + with, for example, typed "@" operator or any other option. Almost all + externally-set compiler directives are honored by FastMM except a few + (currently just one) - look for the "Compiler options for FastMM4" section + below to see what options cannot be externally set and are always + redefined by FastMM4 for itself - even if you set up these compiler options + differently outside FastMM4, they will be silently + redefined, and the new values will be used for FastMM4 only; + - the type of one-byte synchronization variables (accessed via "lock cmpxchg" + or "lock xchg") replaced from Boolean to Byte for stricter type checking; + - those fixed-block-size memory move procedures that are not needed + (under the current bitness and alignment combinations) are + explicitly excluded from compiling, to not rely on the compiler + that is supposed to remove these function after compilation; + - added length parameter to what were the dangerous null-terminated string + operations via PAnsiChar, to prevent potential stack buffer overruns + (or maybe even stack-based exploitation?), and there some Pascal functions + also left, the argument is not yet checked. See the "todo" comments + to figure out where the length is not yet checked. Anyway, since these + memory functions are only used in Debug mode, i.e., in development + environment, not in Release (production), the impact of this + "vulnerability" is minimal (albeit this is a questionable statement); + - removed all non-US-ASCII characters, to avoid using UTF-8 BOM, for + better compatibility with very early versions of Delphi (e.g., Delphi 5), + thanks to Valts Silaputnins; + - support for Lazarus 1.6.4 with FreePascal (the original FastMM4 4.992 + requires modifications, it doesn't work under Lazarus 1.6.4 with FreePascal + out-of-the-box, also tested under Lazarus 1.8.2 / FPC 3.0.4 with Win32 + target; later versions should be also supported. + +Here are the comparison of the Original FastMM4 version 4.992, with default +options compiled for Win64 by Delphi 10.2 Tokyo (Release with Optimization), +and the current FastMM4-AVX branch ("AVX-br."). Under some multi-threading +scenarios, the FastMM4-AVX branch is more than twice as fast compared to the +Original FastMM4. The tests have been run on two different computers: one +under Xeon E5-2543v2 with 2 CPU sockets, each has 6 physical cores +(12 logical threads) - with only 5 physical core per socket enabled for the +test application. Another test was done under an i7-7700K CPU. + +Used the "Multi-threaded allocate, use and free" and "NexusDB" +test cases from the FastCode Challenge Memory Manager test suite, +modified to run under 64-bit. + + Xeon E5-2543v2 2*CPU i7-7700K CPU + (allocated 20 logical (8 logical threads, + threads, 10 physical 4 physical cores), + cores, NUMA), AVX-1 AVX-2 + + Orig. AVX-br. Ratio Orig. AVX-br. Ratio + ------ ----- ------ ----- ----- ------ + 02-threads realloc 96552 59951 62.09% 65213 49471 75.86% + 04-threads realloc 97998 39494 40.30% 64402 47714 74.09% + 08-threads realloc 98325 33743 34.32% 64796 58754 90.68% + 16-threads realloc 116273 45161 38.84% 70722 60293 85.25% + 31-threads realloc 122528 53616 43.76% 70939 62962 88.76% + 64-threads realloc 137661 54330 39.47% 73696 64824 87.96% + NexusDB 02 threads 122846 90380 73.72% 79479 66153 83.23% + NexusDB 04 threads 122131 53103 43.77% 69183 43001 62.16% + NexusDB 08 threads 124419 40914 32.88% 64977 33609 51.72% + NexusDB 12 threads 181239 55818 30.80% 83983 44658 53.18% + NexusDB 16 threads 135211 62044 43.61% 59917 32463 54.18% + NexusDB 31 threads 134815 48132 33.46% 54686 31184 57.02% + NexusDB 64 threads 187094 57672 30.25% 63089 41955 66.50% + +The above tests have been run on 14-Jul-2017. + +Here are some more test results (Compiled by Delphi 10.2 Update 3): + + Xeon E5-2667v4 2*CPU i9-7900X CPU + (allocated 32 logical (20 logical threads, + threads, 16 physical 10 physical cores), + cores, NUMA), AVX-2 AVX-512 + + Orig. AVX-br. Ratio Orig. AVX-br. Ratio + ------ ----- ------ ----- ----- ------ + 02-threads realloc 80544 60025 74.52% 66100 55854 84.50% + 04-threads realloc 80751 47743 59.12% 64772 40213 62.08% + 08-threads realloc 82645 32691 39.56% 62246 27056 43.47% + 12-threads realloc 89951 43270 48.10% 65456 25853 39.50% + 16-threads realloc 95729 56571 59.10% 67513 27058 40.08% + 31-threads realloc 109099 97290 89.18% 63180 28408 44.96% + 64-threads realloc 118589 104230 87.89% 57974 28951 49.94% + NexusDB 01 thread 160100 121961 76.18% 93341 95807 102.64% + NexusDB 02 threads 115447 78339 67.86% 77034 70056 90.94% + NexusDB 04 threads 107851 49403 45.81% 73162 50039 68.39% + NexusDB 08 threads 111490 36675 32.90% 70672 42116 59.59% + NexusDB 12 threads 148148 46608 31.46% 92693 53900 58.15% + NexusDB 16 threads 111041 38461 34.64% 66549 37317 56.07% + NexusDB 31 threads 123496 44232 35.82% 62552 34150 54.60% + NexusDB 64 threads 179924 62414 34.69% 83914 42915 51.14% + +The above tests (on Xeon E5-2667v4 and i9) have been done on 03-May-2018. + +Here is the single-threading performance comparison in some selected +scenarios between FastMM v5.03 dated May 12, 2021 and FastMM4-AVX v1.05 +dated May 20, 2021. FastMM4-AVX is compiled with default optinos. This +test is run on May 20, 2021, under Intel Core i7-1065G7 CPU, Ice Lake +microarchitecture, base frequency: 1.3 GHz, max turbo frequencey: 3.90 GHz, +4 cores, 8 threads. Compiled under Delphi 10.3 Update 3, 64-bit target. +Please note that these are the selected scenarios where FastMM4-AVX is +faster then FastMM5. In other scenarios, especially in multi-threaded +with heavy contention, FastMM5 is faster. + + FastMM5 AVX-br. Ratio + ------ ------ ------ + ReallocMem Small (1-555b) benchmark 1425 1135 79.65% + ReallocMem Medium (1-4039b) benchmark 3834 3309 86.31% + Block downsize 12079 10305 85.31% + Address space creep benchmark 13283 12571 94.64% + Address space creep (larger blocks) 16066 13879 86.39% + Single-threaded reallocate and use 4395 3960 90.10% + Single-threaded tiny reallocate and use 8766 7097 80.96% + Single-threaded allocate, use and free 13912 13248 95.23% + +You can find the program, used to generate the benchmark data, +at https://github.com/maximmasiutin/FastCodeBenchmark + +You can find the program, used to generate the benchmark data, +at https://github.com/maximmasiutin/FastCodeBenchmark + +FastMM4-AVX is released under a dual license, and you may choose to use it +under either the Mozilla Public License 2.0 (MPL 2.1, available from +https://www.mozilla.org/en-US/MPL/2.0/) or the GNU Lesser General Public +License Version 3, dated 29 June 2007 (LGPL 3, available from +https://www.gnu.org/licenses/lgpl.html). + +FastMM4-AVX is free software: you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +FastMM4-AVX is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with FastMM4-AVX (see license_lgpl.txt and license_gpl.txt) +If not, see . + + +FastMM4-AVX Version History: + +- 1.0.6 (25 August 2021) - it can now be compiled with any alignment (8, 16, 32) + regardless of the target (x86, x64) and whether inline assembly is used + or not; the "PurePascal" conditional define to disable inline assembly at + all, however, in this case, efficient locking would not work since it + uses inline assembly; FreePascal now uses the original FreePascal compiler + mode, rather than the Delphi compatibility mode as before; resolved many + FreePascal compiler warnings; supported branch target alignment + in FreePascal inline assembly; small block types now always have + block sizes of 1024 and 2048 bytes, while in previous versions + instead of 1024-byte blocks there were 1056-byte blocks, + and instead of 2048-byte blocks were 2176-byte blocks; + fixed Delphi compiler hints for 64-bit Release mode; Win32 and Win64 + versions compiled under Delphi and FreePascal passed the all the FastCode + validation suites. + +- 1.05 (20 May 2021) - improved speed of releasing memory blocks on higher thread + contention. It is also possible to compile FastMM4-AVX without a single + inline assembly code. Renamed some conditional defines to be self-explaining. + Rewritten some comments to be meaningful. Made it compile under FreePascal + for Linux 64-bit and 32-bit. Also made it compile under FreePascal for + Windows 32-bit and 64-bit. Memory move functions for 152, 184 and 216 bytes + were incorrect Linux. Move216AVX1 and Move216AVX2 Linux implementation had + invalid opcodes. Added support for the GetFPCHeapStatus(). Optimizations on + single-threaded performance. If you define DisablePauseAndSwitchToThread, + it will use EnterCriticalSection/LeaveCriticalSectin. An attempt to free a + memory block twice was not caught under 32-bit Delphi. Added SSE fixed block + copy routines for 32-bit targets. Added support for the "Fast Short REP MOVSB" + CPU feature. Removed redundant SSE code from 64-bit targets. +- 1.04 (O6 October 2020) - improved use of AVX-512 instructions to avoid turbo + clock reduction and SSE/AVX transition penalty; made explicit order of + parameters for GetCPUID to avoid calling convention ambiguity that could + lead to incorrect use of registers and finally crashes, i.e., under Linux; + improved explanations and comments, i.e., about the use of the + synchronization techniques. +- 1.03 (04 May 2018) - minor fixes for the debug mode, FPC compatibility + and code readability cosmetic fixes. +- 1.02 (07 November 2017) - added and tested support for the AVX-512 + instruction set. +- 1.01 (10 October 2017) - made the source code compile under Delphi5, + thanks to Valts Silaputnins. +- 1.00 (27 July 2017) - initial revision. + + +The original FastMM4 description follows: + +Fast Memory Manager 4.993 + +Description: + A fast replacement memory manager for Embarcadero Delphi Win32 applications + that scales well under multi-threaded usage, is not prone to memory + fragmentation, and supports shared memory without the use of external .DLL + files. + +Homepage: + Version 4: https://github.com/pleriche/FastMM4 + Version 5: https://github.com/pleriche/FastMM5 + +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, 16-byte + or 32-byte alignment. + - Good scaling under multi-threaded applications + - Intelligent reallocations. Avoids slow memory move operations through + not performing unnecessary downsizes and by having a minimum percentage + block size growth factor when an in-place block upsize is not possible. + - Resistant to address space fragmentation + - No external DLL required when sharing memory between the application and + external libraries (provided both use this memory manager) + - Optionally reports memory leaks on program shutdown. (This check can be set + to be performed only if Delphi is currently running on the machine, so end + users won't be bothered by the error message.) + - Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3. + +Usage: + Delphi: + Place this unit as the very first unit under the "uses" section in your + project's .dpr file. When sharing memory between an application and a DLL + (e.g. when passing a long string or dynamic array to a DLL function), both the + main application and the DLL must be compiled using this memory manager (with + the required conditional defines set). There are some conditional defines + (inside FastMM4Options.inc) that may be used to tweak the memory manager. To + enable support for a user mode address space greater than 2GB you will have to + use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header. + This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the + application supports an address space larger than 2GB (up to 4GB). In Delphi 6 + and later you can also specify this flag through the compiler directive + {$SetPEFlags $20} + *The EditBin tool ships with the MS Visual C compiler. + C++ Builder 6: + Refer to the instructions inside FastMM4BCB.cpp. + +License: + This work is copyright Professional Software Development / Pierre le Riche. It + is released under a dual license, and you may choose to use it under either the + Mozilla Public License 1.1 (MPL 1.1, available from + http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public + License 2.1 (LGPL 2.1, available from + http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful + or you would like to support further development, a donation would be much + appreciated. + My PayPal account is: + paypal@leriche.org + +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. + E-mail: + fastmm@leriche.org + +Support: + If you have trouble using FastMM, you are welcome to drop me an e-mail at the + address above. + +Disclaimer: + FastMM has been tested extensively with both single and multithreaded + applications on various hardware platforms, but unfortunately, I am not in a + position to make any guarantees. Use it at your own risk. + +Acknowledgements (for version 4): + - Eric Grange for his RecyclerMM on which the earlier versions of FastMM were + based. RecyclerMM was what inspired me to try and write my own memory + manager back in early 2004. + - Primoz Gabrijelcic for several bugfixes and enhancements. + - Dennis Christensen for his tireless efforts with the Fastcode project: + helping to develop, optimize and debug the growing Fastcode library. + - JiYuan Xie for implementing the leak reporting code for C++ Builder. + - Sebastian Zierer for implementing the OS X support. + - Pierre Y. for his suggestions regarding the extension of the memory leak + checking options. + - Hanspeter Widmer for his suggestion to have an option to display install and + uninstall debug messages and moving options to a separate file, as well as + the new usage tracker. + - Anders Isaksson and Greg for finding and identifying the "DelphiIsRunning" + bug under Delphi 5. + - Francois Malan for various suggestions and bug reports. + - Craig Peterson for helping me identify the cache associativity issues that + could arise due to medium blocks always being an exact multiple of 256 bytes. + Also for various other bug reports and enhancement suggestions. + - Jarek Karciarz, Vladimir Ulchenko (Vavan) and Bob Gonder for their help in + implementing the BCB support. + - Ben Taylor for his suggestion to display the object class of all memory + leaks. + - Jean Marc Eber and Vincent Mahon (the Memcheck guys) for the call stack + trace code and also the method used to catch virtual method calls on freed + objects. + - Nahan Hyn for the suggestion to be able to enable or disable memory leak + reporting through a global variable (the "ManualLeakReportingControl" + option.) + - Leonel Togniolli for various suggestions with regard to enhancing the bug + tracking features of FastMM and other helpful advice. + - Joe Bain and Leonel Togniolli for the workaround to QC#10922 affecting + compilation under Delphi 2005. + - Robert Marquardt for the suggestion to make localisation of FastMM easier by + having all string constants together. + - Simon Kissel and Fikret Hasovic for their help in implementing Kylix support. + - Matthias Thoma, Petr Vones, Robert Rossmair and the rest of the JCL team for + their debug info library used in the debug info support DLL and also the + code used to check for a valid call site in the "raw" stack trace code. + - Andreas Hausladen for the suggestion to use an external DLL to enable the + reporting of debug information. + - Alexander Tabakov for various good suggestions regarding the debugging + facilities of FastMM. + - M. Skloff for some useful suggestions and bringing to my attention some + compiler warnings. + - Martin Aignesberger for the code to use madExcept instead of the JCL library + inside the debug info support DLL. + - Diederik and Dennis Passmore for the suggestion to be able to register + expected leaks. + - Dario Tiraboschi and Mark Gebauer for pointing out the problems that occur + when range checking and complete boolean evaluation is turned on. + - Arthur Hoornweg for notifying me of the image base being incorrect for + borlndmm.dll. + - Theo Carr-Brion and Hanspeter Widmer for finding the false alarm error + message "Block Header Has Been Corrupted" bug in FullDebugMode. + - Danny Heijl for reporting the compiler error in "release" mode. + - Omar Zelaya for reporting the BCB support regression bug. + - Dan Miser for various good suggestions, e.g. not logging expected leaks to + file, enhancements the stack trace and messagebox functionality, etc. + - Arjen de Ruijter for fixing the bug in GetMemoryLeakType that caused it + to not properly detect expected leaks registered by class when in + "FullDebugMode". + - Aleksander Oven for reporting the installation problem when trying to use + FastMM in an application together with libraries that all use runtime + packages. + - Kristofer Skaug for reporting the bug that sometimes causes the leak report + to be shown, even when all the leaks have been registered as expected leaks. + Also for some useful enhancement suggestions. + - Guenter Schoch for the "RequireDebuggerPresenceForLeakReporting" option. + - Jan Schlueter for the "ForceMMX" option. + - Hallvard Vassbotn for various good enhancement suggestions. + - Mark Edington for some good suggestions and bug reports. + - Paul Ishenin for reporting the compilation error when the NoMessageBoxes + option is set and also the missing call stack entries issue when "raw" stack + traces are enabled, as well as for the Russian translation. + - Cristian Nicola for reporting the compilation bug when the + CatchUseOfFreedInterfaces option was enabled (4.40). + - Mathias Rauen (madshi) for improving the support for madExcept in the debug + info support DLL. + - Roddy Pratt for the BCB5 support code. + - Rene Mihula for the Czech translation and the suggestion to have dynamic + loading of the FullDebugMode DLL as an option. + - Artur Redzko for the Polish translation. + - Bart van der Werf for helping me solve the DLL unload order problem when + using the debug mode borlndmm.dll library, as well as various other + suggestions. + - JRG ("The Delphi Guy") for the Spanish translation. + - Justus Janssen for Delphi 4 support. + - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compiler + error in version 4.50. + - Johni Jeferson Capeletto for the Brazilian Portuguese translation. + - Kurt Fitzner for reporting the BCB6 compiler error in 4.52. + - Michal Niklas for reporting the Kylix compiler error in 4.54. + - Thomas Speck and Uwe Queisser for German translations. + - Zaenal Mutaqin for the Indonesian translation. + - Carlos Macao for the Portuguese translation. + - Michael Winter for catching the performance issue when reallocating certain + block sizes. + - dzmitry[li] for the Belarussian translation. + - Marcelo Montenegro for the updated Spanish translation. + - Jud Cole for finding and reporting the bug which may trigger a read access + violation when upsizing certain small block sizes together with the + "UseCustomVariableSizeMoveRoutines" option. + - Zdenek Vasku for reporting and fixing the memory manager sharing bug + affecting Windows 95/98/Me. + - RB Winston for suggesting the improvement to GExperts "backup" support. + - Thomas Schulz for reporting the bug affecting large address space support + under FullDebugMode, as well as the recursive call bug when attempting to + report memory leaks when EnableMemoryLeakReporting is disabled. + - Luigi Sandon for the Italian translation. + - Werner Bochtler for various suggestions and bug reports. + - Markus Beth for suggesting the "NeverSleepOnThreadContention" option. + - JiYuan Xie for the Simplified Chinese translation. + - Andrey Shtukaturov for the updated Russian translation, as well as the + Ukrainian translation. + - Dimitry Timokhov for finding two elusive bugs in the memory leak class + detection code. + - Paulo Moreno for fixing the AllocMem bug in FullDebugMode that prevented + large blocks from being cleared. + - Vladimir Bochkarev for the suggestion to remove some unnecessary code if the + MM sharing mechanism is disabled. + - Loris Luise for the version constant suggestion. + - J.W. de Bokx for the MessageBox bugfix. + - Igor Lindunen for reporting the bug that caused the Align16Bytes option to + not work in FullDebugMode. + - Ionut Muntean for the Romanian translation. + - Florent Ouchet for the French translation. + - Marcus Moennig for the ScanMemoryPoolForCorruptions suggestion and the + suggestion to have the option to scan the memory pool before every + operation when in FullDebugMode. + - Francois Piette for bringing under my attention that + ScanMemoryPoolForCorruption was not thread safe. + - Michael Rabatscher for reporting some compiler warnings. + - QianYuan Wang for the Simplified Chinese translation of FastMM4Options.inc. + - Maurizio Lotauro and Christian-W. Budde for reporting some Delphi 5 + compiler errors. + - Patrick van Logchem for the DisableLoggingOfMemoryDumps option. + - Norbert Spiegel for the BCB4 support code. + - Uwe Schuster for the improved string leak detection code. + - Murray McGowan for improvements to the usage tracker. + - Michael Hieke for the SuppressFreeMemErrorsInsideException option as well + as a bugfix to GetMemoryMap. + - Richard Bradbrook for fixing the Windows 95 FullDebugMode support that was + broken in version 4.94. + - Zach Saw for the suggestion to (optionally) use SwitchToThread when + waiting for a lock on a shared resource to be released. + - Everyone who have made donations. Thanks! + - Any other Fastcoders or supporters that I have forgotten, and also everyone + that helped with the older versions. + +Change log: + Version 1.00 (28 June 2004): + - First version (called PSDMemoryManager). Based on RecyclerMM (free block + stack approach) by Eric Grange. + Version 2.00 (3 November 2004): + - Complete redesign and rewrite from scratch. Name changed to FastMM to + reflect this fact. Uses a linked-list approach. Is faster, has less memory + overhead, and will now catch most bad pointers on FreeMem calls. + Version 3.00 (1 March 2005): + - Another rewrite. Reduced the memory overhead by: (a) not having a separate + memory area for the linked list of free blocks (uses space inside free + blocks themselves) (b) batch managers are allocated as part of chunks (c) + block size lookup table size reduced. This should make FastMM more CPU + cache friendly. + Version 4.00 (7 June 2005): + - Yet another rewrite. FastMM4 is in fact three memory managers in one: Small + blocks (up to a few KB) are managed through the binning model in the same + way as previous versions, medium blocks (from a few KB up to approximately + 256K) are allocated in a linked-list fashion, and large blocks are grabbed + directly from the system through VirtualAlloc. This 3-layered design allows + very fast operation with the most frequently used block sizes (small + blocks), while also minimizing fragmentation and imparting significant + overhead savings with blocks larger than a few KB. + Version 4.01 (8 June 2005): + - Added the options "RequireDebugInfoForLeakReporting" and + "RequireIDEPresenceForLeakReporting" as suggested by Pierre Y. + - Fixed the "DelphiIsRunning" function not working under Delphi 5, and + consequently, no leak checking. (Reported by Anders Isaksson and Greg.) + Version 4.02 (8 June 2005): + - Fixed the compilation error when both the "AssumeMultiThreaded" and + "CheckHeapForCorruption options were set. (Reported by Francois Malan.) + Version 4.03 (9 June 2005): + - Added descriptive error messages when FastMM4 cannot be installed because + another MM has already been installed or memory has already been allocated. + Version 4.04 (13 June 2005): + - Added a small fixed offset to the size of medium blocks (previously always + exact multiples of 256 bytes). This makes performance problems due to CPU + cache associativity limitations much less likely. (Reported by Craig + Peterson.) + Version 4.05 (17 June 2005): + - Added the Align16Bytes option. Disable this option to drop the 16 byte + alignment restriction and reduce alignment to 8 bytes for the smallest + block sizes. Disabling Align16Bytes should lower memory consumption at the + cost of complicating the use of aligned SSE move instructions. (Suggested + by Craig Peterson.) + - Added a support unit for C++ Builder 6 - Add FastMM4BCB.cpp and + FastMM4.pas to your BCB project to use FastMM instead of the RTL MM. Memory + leak checking is not supported because (unfortunately) once an MM is + installed under BCB you cannot uninstall it... at least not without + modifying the RTL code in exit.c or patching the RTL code runtime. (Thanks + to Jarek Karciarz, Vladimir Ulchenko and Bob Gonder.) + Version 4.06 (22 June 2005): + - Displays the class of all leaked objects on the memory leak report and also + tries to identify leaked long strings. Previously it only displayed the + sizes of all leaked blocks. (Suggested by Ben Taylor.) + - Added support for displaying the sizes of medium and large block memory + leaks. Previously it only displayed details for small block leaks. + Version 4.07 (22 June 2005): + - Fixed the detection of the class of leaked objects not working under + Windows 98/Me. + Version 4.08 (27 June 2005): + - Added a BorlndMM.dpr project to allow you to build a borlndmm.dll that uses + FastMM4 instead of the default memory manager. You may replace the old + DLL in the Delphi \Bin directory to make the IDE use this memory manager + instead. + Version 4.09 (30 June 2005): + - Included a patch fix for the bug affecting replacement borlndmm.dll files + with Delphi 2005 (QC#14007). Compile the patch, close Delphi, and run it + once to patch your vclide90.bpl. You will now be able to use the + replacement borlndmm.dll to speed up the Delphi 2005 IDE as well. + Version 4.10 (7 July 2005): + - Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown + code of borlndmm.dll has been called"), FastMM cannot be uninstalled + safely when used inside a replacement borlndmm.dll for the IDE. Added a + conditional define "NeverUninstall" for this purpose. + - Added the "FullDebugMode" option to pad all blocks with a header and footer + to help you catch memory overwrite bugs in your applications. All blocks + returned to freemem are also zeroed out to help catch bugs involving the + use of previously freed blocks. Also catches attempts at calling virtual + methods of freed objects provided the block in question has not been reused + since the object was freed. Displays stack traces on error to aid debugging. + - Added the "LogErrorsToFile" option to log all errors to a text file in the + same folder as the application. + - Added the "ManualLeakReportingControl" option (suggested by Nahan Hyn) to + enable control over whether the memory leak report should be done or not + via a global variable. + Version 4.11 (7 July 2005): + - Fixed a compilation error under Delphi 2005 due to QC#10922. (Thanks to Joe + Bain and Leonel Togniolli.) + - Fixed leaked object classes not displaying in the leak report in + "FullDebugMode". + Version 4.12 (8 July 2005): + - Moved all the string constants to one place to make it easier to do + translations into other languages. (Thanks to Robert Marquardt.) + - Added support for Kylix. Some functionality is currently missing: No + support for detecting the object class on leaks and also no MM sharing. + (Thanks to Simon Kissel and Fikret Hasovic). + Version 4.13 (11 July 2005): + - Added the FastMM_DebugInfo.dll support library to display debug info for + stack traces. + - Stack traces for the memory leak report is now logged to the log file in + "FullDebugMode". + Version 4.14 (14 July 2005): + - Fixed string leaks not being detected as such in "FullDebugMode". (Thanks + to Leonel Togniolli.) + - Fixed the compilation error in "FullDebugMode" when "LogErrorsToFile" is + not set. (Thanks to Leonel Togniolli.) + - Added a "Release" option to allow the grouping of various options and to + make it easier to make debug and release builds. (Thanks to Alexander + Tabakov.) + - Added a "HideMemoryLeakHintMessage" option to not display the hint below + the memory leak message. (Thanks to Alexander Tabakov.) + - Changed the fill character for "FullDebugMode" from zero to $80 to be able + to differentiate between invalid memory accesses using nil pointers to + invalid memory accesses using fields of freed objects. FastMM tries to + reserve the 64K block starting at $80800000 at startup to ensure that an + A/V will occur when this block is accessed. (Thanks to Alexander Tabakov.) + - Fixed some compiler warnings. (Thanks to M. Skloff) + - Fixed some display bugs in the memory leak report. (Thanks to Leonel + Togniolli.) + - Added a "LogMemoryLeakDetailToFile" option. Some applications leak a lot of + memory and can make the log file grow very large very quickly. + - Added the option to use madExcept instead of the JCL Debug library in the + debug info support DLL. (Thanks to Martin Aignesberger.) + - Added procedures "GetMemoryManagerState" and "GetMemoryMap" to retrieve + statistics about the current state of the memory manager and memory pool. + (A usage tracker form together with a demo is also available.) + Version 4.15 (14 July 2005): + - Fixed a false 4GB(!) memory leak reported in some instances. + Version 4.16 (15 July 2005): + - Added the "CatchUseOfFreedInterfaces" option to catch the use of interfaces + of freed objects. This option is not compatible with checking that a freed + block has not been modified, so enable this option only when hunting an + invalid interface reference. (Only relevant if "FullDebugMode" is set.) + - During shutdown FastMM now checks that all free blocks have not been + modified since being freed. (Only when "FullDebugMode" is set and + "CatchUseOfFreedInterfaces" is disabled.) + Version 4.17 (15 July 2005): + - Added the AddExpectedMemoryLeaks and RemoveExpectedMemoryLeaks procedures to + register/unregister expected leaks, thus preventing the leak report from + displaying if only expected leaks occurred. (Thanks to Diederik and Dennis + Passmore for the suggestion.) (Note: these functions were renamed in later + versions.) + - Fixed the "LogMemoryLeakDetailToFile" not logging memory leak detail to file + as it is supposed to. (Thanks to Leonel Togniolli.) + Version 4.18 (18 July 2005): + - Fixed some issues when range checking or complete boolean evaluation is + switched on. (Thanks to Dario Tiraboschi and Mark Gebauer.) + - Added the "OutputInstallUninstallDebugString" option to display a message when + FastMM is installed or uninstalled. (Thanks to Hanspeter Widmer.) + - Moved the options to a separate include file. (Thanks to Hanspeter Widmer.) + - Moved message strings to a separate file for easy translation. + Version 4.19 (19 July 2005): + - Fixed Kylix support that was broken in 4.14. + Version 4.20 (20 July 2005): + - Fixed a false memory overwrite report at shutdown in "FullDebugMode". If you + consistently got a "Block Header Has Been Corrupted" error message during + shutdown at address $xxxx0070 then it was probably a false alarm. (Thanks to + Theo Carr-Brion and Hanspeter Widmer.} + Version 4.21 (27 July 2005): + - Minor change to the block header flags to make it possible to immediately + tell whether a medium block is being used as a small block pool or not. + (Simplifies the leak checking and status reporting code.) + - Expanded the functionality around the management of expected memory leaks. + - Added the "ClearLogFileOnStartup" option. Deletes the log file during + initialization. (Thanks to M. Skloff.) + - Changed "OutputInstallUninstallDebugString" to use OutputDebugString instead + of MessageBox. (Thanks to Hanspeter Widmer.) + Version 4.22 (1 August 2005): + - Added a FastAllocMem function that avoids an unnecessary FillChar call with + large blocks. + - Changed large block resizing behavior to be a bit more conservative. Large + blocks will be downsized if the new size is less than half of the old size + (the threshold was a quarter previously). + Version 4.23 (6 August 2005): + - Fixed BCB6 support (Thanks to Omar Zelaya). + - Renamed "OutputInstallUninstallDebugString" to "UseOutputDebugString", and + added debug string output on memory leak or error detection. + Version 4.24 (11 August 2005): + - Added the "NoMessageBoxes" option to suppress the display of message boxes, + which is useful for services that should not be interrupted. (Thanks to Dan + Miser). + - Changed the stack trace code to return the line number of the caller and not + the line number of the return address. (Thanks to Dan Miser). + Version 4.25 (15 August 2005): + - Fixed GetMemoryLeakType not detecting expected leaks registered by class + when in "FullDebugMode". (Thanks to Arjen de Ruijter). + Version 4.26 (18 August 2005): + - Added a "UseRuntimePackages" option that allows FastMM to be used in a main + application together with DLLs that all use runtime packages. (Thanks to + Aleksander Oven.) + Version 4.27 (24 August 2005): + - Fixed a bug that sometimes caused the leak report to be shown even though all + leaks were registered as expected leaks. (Thanks to Kristofer Skaug.) + Version 4.29 (30 September 2005): + - Added the "RequireDebuggerPresenceForLeakReporting" option to only display + the leak report if the application is run inside the IDE. (Thanks to Guenter + Schoch.) + - Added the "ForceMMX" option, which when disabled will check the CPU for + MMX compatibility before using MMX. (Thanks to Jan Schlueter.) + - Added the module name to the title of error dialogs to more easily identify + which application caused the error. (Thanks to Kristofer Skaug.) + - Added an ASCII dump to the "FullDebugMode" memory dumps. (Thanks to Hallvard + Vassbotn.) + - Added the option "HideExpectedLeaksRegisteredByPointer" to suppress the + display and logging of expected memory leaks that were registered by pointer. + (Thanks to Dan Miser.) Leaks registered by size or class are often ambiguous, + so these expected leaks are always logged to file (in FullDebugMode) and are + never hidden from the leak display (only displayed if there is at least one + unexpected leak). + - Added a procedure "GetRegisteredMemoryLeaks" to return a list of all + registered memory leaks. (Thanks to Dan Miser.) + - Added the "RawStackTraces" option to perform "raw" stack traces, negating + the need for stack frames. This will usually result in more complete stack + traces in FullDebugMode error reports, but it is significantly slower. + (Thanks to Hallvard Vassbotn, Dan Miser and the JCL team.) + Version 4.31 (2 October 2005): + - Fixed the crash bug when both "RawStackTraces" and "FullDebugMode" were + enabled. (Thanks to Dan Miser and Mark Edington.) + Version 4.33 (6 October 2005): + - Added a header corruption check to all memory blocks that are identified as + leaks in FullDebugMode. This allows better differentiation between memory + pool corruption bugs and actual memory leaks. + - Fixed the stack overflow bug when using "RawStackTraces". + Version 4.35 (6 October 2005): + - Fixed a compilation error when the "NoMessageBoxes" option is set. (Thanks + to Paul Ishenin.) + - Before performing a "raw" stack trace, FastMM now checks whether exception + handling is in place. If exception handling is not in place FastMM falls + back to stack frame tracing. (Exception handling is required to handle the + possible A/Vs when reading invalid call addresses. Exception handling is + usually always available except when SysUtils hasn't been initialized yet or + after SysUtils has been finalized.) + Version 4.37 (8 October 2005): + - Fixed the missing call stack trace entry issue when dynamically loading DLLs. + (Thanks to Paul Ishenin.) + Version 4.39 (12 October 2005): + - Restored the performance with "RawStackTraces" enabled back to the level it + was in 4.35. + - Fixed the stack overflow error when using "RawStackTraces" that I thought I + had fixed in 4.31, but unfortunately didn't. (Thanks to Craig Peterson.) + Version 4.40 (13 October 2005): + - Improved "RawStackTraces" to have less incorrect extra entries. (Thanks to + Craig Peterson.) + - Added the Russian (by Paul Ishenin) and Afrikaans translations of + FastMM4Messages.pas. + Version 4.42 (13 October 2005): + - Fixed the compilation error when "CatchUseOfFreedInterfaces" is enabled. + (Thanks to Cristian Nicola.) + Version 4.44 (25 October 2005): + - Implemented a FastGetHeapStatus function in analogy with GetHeapStatus. + (Suggested by Cristian Nicola.) + - Shifted more of the stack trace code over to the support dll to allow third + party vendors to make available their own stack tracing and stack trace + logging facilities. + - Mathias Rauen (madshi) improved the support for madExcept in the debug info + support DLL. Thanks! + - Added support for BCB5. (Thanks to Roddy Pratt.) + - Added the Czech translation by Rene Mihula. + - Added the "DetectMMOperationsAfterUninstall" option. This will catch + attempts to use the MM after FastMM has been uninstalled, and is useful for + debugging. + Version 4.46 (26 October 2005): + - Renamed FastMM_DebugInfo.dll to FastMM_FullDebugMode.dll and made the + dependency on this library a static one. This solves a DLL unload order + problem when using FullDebugMode together with the replacement + borlndmm.dll. (Thanks to Bart van der Werf.) + - Added the Polish translation by Artur Redzko. + Version 4.48 (10 November 2005): + - Fixed class detection for objects leaked in dynamically loaded DLLs that + were relocated. + - Fabio Dell'Aria implemented support for EurekaLog in the FullDebugMode + support DLL. Thanks! + - Added the Spanish translation by JRG ("The Delphi Guy"). + Version 4.49 (10 November 2005): + - Implemented support for installing replacement AllocMem and leak + registration mechanisms for Delphi/BCB versions that support it. + - Added support for Delphi 4. (Thanks to Justus Janssen.) + Version 4.50 (5 December 2005): + - Renamed the ReportMemoryLeaks global variable to ReportMemoryLeaksOnShutdown + to be more consistent with the Delphi 2006 memory manager. + - Improved the handling of large blocks. Large blocks can now consist of + several consecutive segments allocated through VirtualAlloc. This + significantly improves speed when frequently resizing large blocks, since + these blocks can now often be upsized in-place. + Version 4.52 (7 December 2005): + - Fixed the compilation error with Delphi 5. (Thanks to Vadim Lopushansky and + Charles Vinal for reporting the error.) + Version 4.54 (15 December 2005): + - Added the Brazilian Portuguese translation by Johni Jeferson Capeletto. + - Fixed the compilation error with BCB6. (Thanks to Kurt Fitzner.) + Version 4.56 (20 December 2005): + - Fixed the Kylix compilation problem. (Thanks to Michal Niklas.) + Version 4.58 (1 February 2006): + - Added the German translations by Thomas Speck and Uwe Queisser. + - Added the Indonesian translation by Zaenal Mutaqin. + - Added the Portuguese translation by Carlos Macao. + Version 4.60 (21 February 2006): + - Fixed a performance issue due to an unnecessary block move operation when + allocating a block in the range 1261-1372 bytes and then reallocating it in + the range 1373-1429 bytes twice. (Thanks to Michael Winter.) + - Added the Belarussian translation by dzmitry[li]. + - Added the updated Spanish translation by Marcelo Montenegro. + - Added a new option "EnableSharingWithDefaultMM". This option allows FastMM + to be shared with the default MM of Delphi 2006. It is on by default, but + MM sharing has to be enabled otherwise it has no effect (refer to the + documentation for the "ShareMM" and "AttemptToUseSharedMM" options). + Version 4.62 (22 February 2006): + - Fixed a possible read access violation in the MoveX16LP routine when the + UseCustomVariableSizeMoveRoutines option is enabled. (Thanks to Jud Cole for + some great detective work in finding this bug.) + - Improved the downsizing behaviour of medium blocks to better correlate with + the reallocation behaviour of small blocks. This change reduces the number + of transitions between small and medium block types when reallocating blocks + in the 0.7K to 2.6K range. It cuts down on the number of memory move + operations and improves performance. + Version 4.64 (31 March 2006): + - Added the following functions for use with FullDebugMode (and added the + exports to the replacement BorlndMM.dll): SetMMLogFileName, + GetCurrentAllocationGroup, PushAllocationGroup, PopAllocationGroup and + LogAllocatedBlocksToFile. The purpose of these functions is to allow you to + identify and log related memory leaks while your application is still + running. + - Fixed a bug in the memory manager sharing mechanism affecting Windows + 95/98/ME. (Thanks to Zdenek Vasku.) + Version 4.66 (9 May 2006): + - Added a hint comment in this file so that FastMM4Messages.pas will also be + backed up by GExperts. (Thanks to RB Winston.) + - Fixed a bug affecting large address space (> 2GB) support under + FullDebugMode. (Thanks to Thomas Schulz.) + Version 4.68 (3 July 2006): + - Added the Italian translation by Luigi Sandon. + - If FastMM is used inside a DLL it will now use the name of the DLL as base + for the log file name. (Previously it always used the name of the main + application executable file.) + - Fixed a rare A/V when both the FullDebugMode and RawStackTraces options were + enabled. (Thanks to Primoz Gabrijelcic.) + - Added the "NeverSleepOnThreadContention" option. This option may improve + performance if the ratio of the the number of active threads to the number + of CPU cores is low (typically < 2). This option is only useful for 4+ CPU + systems, it almost always hurts performance on single and dual CPU systems. + (Thanks to Werner Bochtler and Markus Beth.) + Version 4.70 (4 August 2006): + - Added the Simplified Chinese translation by JiYuan Xie. + - Added the updated Russian as well as the Ukrainian translation by Andrey + Shtukaturov. + - Fixed two bugs in the leak class detection code that would sometimes fail + to detect the class of leaked objects and strings, and report them as + 'unknown'. (Thanks to Dimitry Timokhov) + Version 4.72 (24 September 2006): + - Fixed a bug that caused AllocMem to not clear blocks > 256K in + FullDebugMode. (Thanks to Paulo Moreno.) + Version 4.74 (9 November 2006): + - Fixed a bug in the segmented large block functionality that could lead to + an application freeze when upsizing blocks greater than 256K in a + multithreaded application (one of those "what the heck was I thinking?" + type bugs). + Version 4.76 (12 January 2007): + - Changed the RawStackTraces code in the FullDebugMode DLL + to prevent it from modifying the Windows "GetLastError" error code. + (Thanks to Primoz Gabrijelcic.) + - Fixed a threading issue when the "CheckHeapForCorruption" option was + enabled, but the "FullDebugMode" option was disabled. (Thanks to Primoz + Gabrijelcic.) + - Removed some unnecessary startup code when the MM sharing mechanism is + disabled. (Thanks to Vladimir Bochkarev.) + - In FullDebugMode leaked blocks would sometimes be reported as belonging to + the class "TFreedObject" if they were allocated but never used. Such blocks + will now be reported as "unknown". (Thanks to Francois Malan.) + - In recent versions the replacement borlndmm.dll created a log file (when + enabled) that used the "borlndmm" prefix instead of the application name. + It is now fixed to use the application name, however if FastMM is used + inside other DLLs the name of those DLLs will be used. (Thanks to Bart van + der Werf.) + - Added a "FastMMVersion" constant. (Suggested by Loris Luise.) + - Fixed an issue with error message boxes not displaying under certain + configurations. (Thanks to J.W. de Bokx.) + - FastMM will now display only one error message at a time. If many errors + occur in quick succession, only the first error will be shown (but all will + be logged). This avoids a stack overflow with badly misbehaved programs. + (Thanks to Bart van der Werf.) + - Added a LoadDebugDLLDynamically option to be used in conjunction with + FullDebugMode. In this mode FastMM_FullDebugMode.dll is loaded dynamically. + If the DLL cannot be found, stack traces will not be available. (Thanks to + Rene Mihula.) + Version 4.78 (1 March 2007): + - The MB_DEFAULT_DESKTOP_ONLY constant that is used when displaying messages + boxes since 4.76 is not defined under Kylix, and the source would thus not + compile. That constant is now defined. (Thanks to Werner Bochtler.) + - Moved the medium block locking code that was duplicated in several places + to a subroutine to reduce code size. (Thanks to Hallvard Vassbotn.) + - Fixed a bug in the leak registration code that sometimes caused registered + leaks to be reported erroneously. (Thanks to Primoz Gabrijelcic.) + - Added the NoDebugInfo option (on by default) that suppresses the generation + of debug info for the FastMM4.pas unit. This will prevent the integrated + debugger from stepping into the memory manager. (Thanks to Primoz + Gabrijelcic.) + - Increased the default stack trace depth in FullDebugMode from 9 to 10 to + ensure that the Align16Bytes setting works in FullDebugMode. (Thanks to + Igor Lindunen.) + - Updated the Czech translation. (Thanks to Rene Mihula.) + Version 4.84 (7 July 2008): + - Added the Romanian translation. (Thanks to Ionut Muntean.) + - Optimized the GetMemoryMap procedure to improve speed. + - Added the GetMemoryManagerUsageSummary function that returns a summary of + the GetMemoryManagerState call. (Thanks to Hallvard Vassbotn.) + - Added the French translation. (Thanks to Florent Ouchet.) + - Added the "AlwaysAllocateTopDown" FullDebugMode option to help with + catching bad pointer arithmetic code in an address space > 2GB. This option + is enabled by default. + - Added the "InstallOnlyIfRunningInIDE" option. Enable this option to + only install FastMM as the memory manager when the application is run + inside the Delphi IDE. This is useful when you want to deploy the same EXE + that you use for testing, but only want the debugging features active on + development machines. When this option is enabled and the application is + not being run inside the IDE, then the default Delphi memory manager will + be used (which, since Delphi 2006, is FastMM without FullDebugMode.) This + option is off by default. + - Added the "FullDebugModeInIDE" option. This is a convenient shorthand for + enabling FullDebugMode, InstallOnlyIfRunningInIDE and + LoadDebugDLLDynamically. This causes FastMM to be used in FullDebugMode + when the application is being debugged on development machines, and the + default memory manager when the same executable is deployed. This allows + the debugging and deployment of an application without having to compile + separate executables. This option is off by default. + - Added a ScanMemoryPoolForCorruptions procedure that checks the entire + memory pool for corruptions and raises an exception if one is found. It can + be called at any time, but is only available in FullDebugMode. (Thanks to + Marcus Moennig.) + - Added a global variable "FullDebugModeScanMemoryPoolBeforeEveryOperation". + When this variable is set to true and FullDebugMode is enabled, then the + entire memory pool is checked for consistency before every GetMem, FreeMem + and ReallocMem operation. An "Out of Memory" error is raised if a + corruption is found (and this variable is set to false to prevent recursive + errors). This obviously incurs a massive performance hit, so enable it only + when hunting for elusive memory corruption bugs. (Thanks to Marcus Moennig.) + - Fixed a bug in AllocMem that caused the FPU stack to be shifted by one + position. + - Changed the default for option "EnableMMX" to false, since using MMX may + cause unexpected behaviour in code that passes parameters on the FPU stack + (like some "compiler magic" routines, e.g. VarFromReal). + - Removed the "EnableSharingWithDefaultMM" option. This is now the default + behaviour and cannot be disabled. (FastMM will always try to share memory + managers between itself and the default memory manager when memory manager + sharing is enabled.) + - Introduced a new memory manager sharing mechanism based on memory mapped + files. This solves compatibility issues with console and service + applications. This sharing mechanism currently runs in parallel with the + old mechanism, but the old mechanism can be disabled by undefining + "EnableBackwardCompatibleMMSharing" in FastMM4Options.inc. + - Fixed the recursive call error when the EnableMemoryLeakReporting option + is disabled and an attempt is made to register a memory leak under Delphi + 2006 or later. (Thanks to Thomas Schulz.) + - Added a global variable "SuppressMessageBoxes" to enable or disable + message boxes at runtime. (Thanks to Craig Peterson.) + - Added the leak reporting code for C++ Builder, as well as various other + C++ Builder bits written by JiYuan Xie. (Thank you!) + - Added the new Usage Tracker written by Hanspeter Widmer. (Thank you!) + Version 4.86 (31 July 2008): + - Tweaked the string detection algorithm somewhat to be less strict, and + allow non-class leaks to be more often categorized as strings. + - Fixed a compilation error under Delphi 5. + - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread + safe. (Thanks to Francois Piette.) + Version 4.88 (13 August 2008): + - Fixed compiler warnings in NoOpRegisterExpectedMemoryLeak and + NoOpUnRegisterExpectedMemoryLeak. (Thanks to Michael Rabatscher.) + - Added the Simplified Chinese translation of FastMM4Options.inc by + QianYuan Wang. (Thank you!) + - Included the updated C++ Builder files with support for BCB6 without + update 4 applied. (Submitted by JiYuan Xie. Thanks!) + - Fixed a compilation error under Delphi 5. + - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread + safe - for real this time. (Thanks to Francois Piette.) + Version 4.90 (9 September 2008): + - Added logging of the thread ID when capturing and displaying stack + traces. (Suggested by Allen Bauer and Mark Edington.) + - Fixed a Delphi 5 compiler error under FullDebugMode. (Thanks to Maurizio + Lotauro and Christian-W. Budde.) + - Changed a default setting in FastMM4Options.inc: RawStackTraces is now + off by default due to the high number of support requests I receive with + regards to the false positives it may cause. I recommend compiling debug + builds of applications with the "Stack Frames" option enabled. + - Fixed a compilation error under Kylix. (Thanks to Werner Bochtler.) + - Official support for Delphi 2009. + Version 4.92 (25 November 2008): + - Added the DisableLoggingOfMemoryDumps option under FullDebugMode. When + this option is set, memory dumps will not be logged for memory leaks or + errors. (Thanks to Patrick van Logchem.) + - Exposed the class and string type detection code in the interface section + for use in application code (if required). (Requested by Patrick van + Logchem.) + - Fixed a bug in SetMMLogFileName that could cause the log file name to be + set incorrectly. + - Added BCB4 support. (Thanks to Norbert Spiegel.) + - Included the updated Czech translation by Rene Mihula. + - When FastMM raises an error due to a freed block being modified, it now + logs detail about which bytes in the block were modified. + Version 4.94 (28 August 2009): + - Added the DoNotInstallIfDLLMissing option that prevents FastMM from + installing itself if the FastMM_FullDebugMode.dll library is not + available. (Only applicable when FullDebugMode and LoadDebugDLLDynamically + are both enabled.) This is useful when the same executable will be used for + both debugging and deployment - when the debug support DLL is available + FastMM will be installed in FullDebugMode, and otherwise the default memory + manager will be used. + - Added the FullDebugModeWhenDLLAvailable option that combines the + FullDebugMode, LoadDebugDLLDynamically and DoNotInstallIfDLLMissing options. + - Re-enabled RawStackTraces by default. The frame based stack traces (even + when compiling with stack frames enabled) are generally too incomplete. + - Improved the speed of large block operations under FullDebugMode: Since + large blocks are never reused, there is no point in clearing them before + and after use (so it does not do that anymore). + - If an error occurs in FullDebugMode and FastMM is unable to append to the + log file, it will attempt to write to a log file of the same name in the + "My Documents" folder. This feature is helpful when the executable resides + in a read-only location and the default log file, which is derived from the + executable name, would thus not be writeable. + - Added support for controlling the error log file location through an + environment variable. If the 'FastMMLogFilePath' environment variable is + set then any generated error logs will be written to the specified folder + instead of the default location (which is the same folder as the + application). + - Improved the call instruction detection code in the FastMM_FullDebugMode + library. (Thanks to the JCL team.) + - Improved the string leak detection and reporting code. (Thanks to Uwe + Schuster.) + - New FullDebugMode feature: Whenever FreeMem or ReallocMem is called, FastMM + will check that the block was actually allocated through the same FastMM + instance. This is useful for tracking down memory manager sharing issues. + - Compatible with Delphi 2010. + Version 4.96 (31 August 2010): + - Reduced the minimum block size to 4 bytes from the previous value of 12 + bytes (only applicable to 8 byte alignment). This reduces memory usage if + the application allocates many blocks <= 4 bytes in size. + - Added colour-coded change indication to the FastMM usage tracker, making + it easier to spot changes in the memory usage grid. (Thanks to Murray + McGowan.) + - Added the SuppressFreeMemErrorsInsideException FullDebugMode option: If + FastMM encounters a problem with a memory block inside the FullDebugMode + FreeMem handler then an "invalid pointer operation" exception will usually + be raised. If the FreeMem occurs while another exception is being handled + (perhaps in the try.. finally code) then the original exception will be + lost. With this option set FastMM will ignore errors inside FreeMem when an + exception is being handled, thus allowing the original exception to + propagate. This option is on by default. (Thanks to Michael Hieke.) + - Fixed Windows 95 FullDebugMode support that was broken in 4.94. (Thanks to + Richard Bradbrook.) + - Fixed a bug affecting GetMemoryMap performance and accuracy of measurements + above 2GB if a large address space is not enabled for the project. (Thanks + to Michael Hieke.) + - Added the FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak boolean flag. + When set, all allocations are automatically registered as expected memory + leaks. Only available in FullDebugMode. (Thanks to Brian Cook.) + - Compatible with Delphi XE. + Version 4.97 (30 September 2010): + - Fixed a crash bug (that crept in in 4.96) that may manifest itself when + resizing a block to 4 bytes or less. + - Added the UseSwitchToThread option. Set this option to call SwitchToThread + instead of sitting in a "busy waiting" loop when a thread contention + occurs. This is used in conjunction with the NeverSleepOnThreadContention + option, and has no effect unless NeverSleepOnThreadContention is also + defined. This option may improve performance with many CPU cores and/or + threads of different priorities. Note that the SwitchToThread API call is + only available on Windows 2000 and later. (Thanks to Zach Saw.) + Version 4.98 (23 September 2011): + - Added the FullDebugModeCallBacks define which adds support for memory + manager event callbacks. This allows the application to be notified of + memory allocations, frees and reallocations as they occur. (Thanks to + Jeroen Pluimers.) + - Added security options ClearMemoryBeforeReturningToOS and + AlwaysClearFreedMemory to force the clearing of memory blocks after being + freed. This could possibly provide some protection against information + theft, but at a significant performance penalty. (Thanks to Andrey + Sozonov.) + - Shifted the code in the initialization section to a procedure + RunInitializationCode. This allows the startup code to be called before + InitUnits, which is required by some software protection tools. + - Added support for Delphi XE2 (Windows 32-bit and Windows 64-bit platforms + only). + Version 4.99 (6 November 2011): + - Fixed crashes in the 64-bit BASM codepath when more than 4GB of memory is + allocated. + - Fixed bad record alignment under 64-bit that affected performance. + - Fixed compilation errors with some older compilers. + Version 4.991 (3 September 2012) + - Added the LogMemoryManagerStateToFile call. This call logs a summary of + the memory manager state to file: The total allocated memory, overhead, + efficiency, and a breakdown of allocated memory by class and string type. + This call may be useful to catch objects that do not necessarily leak, but + do linger longer than they should. + - OS X support added by Sebastian Zierer + - Compatible with Delphi XE3 + Version 4.992 (21 October 2016) + - OS X full debug mode added by Sebastian Zierer + - Included the average block size in the memory state log file. (Thanks to + Hallvard Vassbotn) + - Support added for Free Pascal's OS X and Linux targets, both i386 and + x86-64. (Thanks to Zoe Peterson - some fixes by Arnaud Bouchez) + - Added the LogLockContention option which may be used to track down areas + in the application that lead to frequent lock contentions in the memory + manager. (Primoz Gabrijelcic) + - Support for release stacks added by Primoz Gabrijelcic. Define + "UseReleaseStack" to use this new feature: If a block cannot be released + immediately during a FreeMem call the block will added to a list of blocks + that will be freed later, either in the background cleanup thread or during + the next call to FreeMem. + Version 4.993 (10 August 2021) + - Added some "address space slack" under FullDebugMode. This reserves a + block of address space on startup (currently 5MB) that is released just + before the first time an EOutOfMemory exception is raised, allowing some + GetMem calls following the initial EOutOfMemory to succeed. This allows + the application to perform any error logging and other shutdown operations + successfully that would have failed it the address space was actually + completely exhausted. (Under FullDebugMode address space is never released + back to the operating system so once the address space has been exhausted + there is very little room to manoeuvre.) + - Added the RestrictDebugDLLLoadPath option to only load the debug DLL from + the host module directory. + - Performance and other enhancements to the call stack generation. (Thanks to + Andreas Hausladen.) + - Added FastMM artwork. (Thanks to Jim McKeeth.) + - Added the FastMM_GetInstallationState function: Allows determination of + whether FastMM is installed or not, and if not whether the default memory + manager is in use or a different third party memory manager. + +*) + +unit FastMM4; + +interface + +{$Include FastMM4Options.inc} + +{Compiler version defines} +{$ifndef fpc} + {$ifndef BCB} + {$ifdef ver120} + {$define Delphi4or5} + {$endif} + {$ifdef ver130} + {$define Delphi4or5} + {$endif} + {$ifdef ver140} + {$define Delphi6} + {$endif} + {$ifdef ver150} + {$define Delphi7} + {$endif} + {$ifdef ver170} + {$define Delphi2005} + {$endif} + {$else} + {for BCB4, use the Delphi 5 codepath} + {$ifdef ver120} + {$define Delphi4or5} + {$define BCB4} + {$endif} + {for BCB5, use the Delphi 5 codepath} + {$ifdef ver130} + {$define Delphi4or5} + {$endif} + {$endif} + {$ifdef ver180} + {$define BDS2006} + {$endif} + {$define 32Bit} + {$ifndef Delphi4or5} + {$if SizeOf(Pointer) = 8} + {$define 64Bit} + {$undef 32Bit} + {$ifend} + {$if CompilerVersion >= 23} + {$define XE2AndUp} + {$ifend} + {$define BCB6OrDelphi6AndUp} + {$ifndef BCB} + {$define Delphi6AndUp} + {$endif} + {$ifndef Delphi6} + {$define BCB6OrDelphi7AndUp} + {$ifndef BCB} + {$define Delphi7AndUp} + {$endif} + {$ifndef BCB} + {$ifndef Delphi7} + {$ifndef Delphi2005} + {$define BDS2006AndUp} + {$endif} + {$endif} + {$endif} + {$endif} + {$endif} +{$else} + {Defines for FreePascal} + {$define DisableAVX512} + {$asmmode intel} + {$ifdef CPUX64} + {$asmmode intel} + {$define 64bit} + {$define fpc64bit} + {$undef 32bit} + {$else} + {$define 32bit} + {$undef 64bit} + {$endif} +{$endif} + +{$ifndef 64Bit} + {do not support AVX unless we are in the 64-bit mode} + {$undef EnableAVX} +{$endif} + +{ The assembly implementation of FastGetmem and FastFreemem will check whether + "pause" and SwitchToThread() are available, otherwisw will jump to pascal versions + of FastGetmem and FastFreemem. However, if we assume that "pause" and SwitchToThread() + are available (AssumePauseAndSwitchToThreadAvailable), we would not do any check, + i.e., undefine CheckPauseAndSwitchToThreadFor + } + +{$ifdef ASMVersion} +{$define CheckPauseAndSwitchToThreadForAsmVersion} +{$endif} + +{$ifdef DisablePauseAndSwitchToThread} + {$undef ASMVersion} + {$undef AssumePauseAndSwitchToThreadAvailable} + {$undef CheckPauseAndSwitchToThreadForAsmVersion} + {$undef FastGetMemNeedAssemblerCode} + {$define FastGetMemNeedPascalCode} +{$else} + {$ifdef 64bit} + {$define AssumePauseAndSwitchToThreadAvailable} + {$endif} + {$ifdef AssumePauseAndSwitchToThreadAvailable} + {$undef CheckPauseAndSwitchToThreadForAsmVersion} + {$endif} +{$endif} + +{$ifdef 64bit} + + {$ifdef EnableAVX} + {Under 64 bit with AVX, memory blocks must always be 32-byte aligned, + since we are using 32-bit load/store, and they have to be aligned, + a store across page boundary invokes 150-cycle penalty on Sandy Bridge} + {$define Align32Bytes} + {$endif} + + {No need for MMX under 64-bit, since SSE2 is available} + {$undef EnableMMX} + {There is little need for raw stack traces under 64-bit, since frame based + stack traces are much more accurate than under 32-bit. (And frame based + stack tracing is much faster.)} + {$undef RawStackTraces} +{$endif} + +{Lock contention logging requires ~ASMVersion.} +{$ifdef LogLockContention} + {$undef ASMVersion} +{$endif} + +{Release stack requires ~ASMVersion (for now).} +{$ifdef UseReleaseStack} + {$undef ASMVersion} + {$ifdef FullDebugMode} + {$message error 'UseReleaseStack is not compatible with FullDebugMode'} + {$endif} +{$endif} + +{IDE debug mode always enables FullDebugMode and dynamic loading of the FullDebugMode DLL.} +{$ifdef FullDebugModeInIDE} + {$define InstallOnlyIfRunningInIDE} + {$define FullDebugMode} + {$define LoadDebugDLLDynamically} +{$endif} + +{Install in FullDebugMode only when the DLL is available?} +{$ifdef FullDebugModeWhenDLLAvailable} + {$define FullDebugMode} + {$define LoadDebugDLLDynamically} + {$define DoNotInstallIfDLLMissing} +{$endif} + +{$ifdef Linux} + {$define POSIX} + {$ifdef 64Bit} + {$define PIC} // Linux 64bit ASM is PIC + {$endif} + {$ifndef FPC} + {$define KYLIX} + {$endif} +{$endif} + +{$ifdef DARWIN} + {$define POSIX} + {$define PIC} +{$endif} + +{Some features not currently supported under Kylix / OS X} +{$ifdef POSIX} + {$ifndef MACOS} + {$undef FullDebugMode} + {$undef LogErrorsToFile} + {$undef LogMemoryLeakDetailToFile} + {$endif} + {$undef ShareMM} + {$undef AttemptToUseSharedMM} + {$undef RequireIDEPresenceForLeakReporting} + {$undef UseOutputDebugString} + {$ifdef PIC} + {BASM version does not support position independent code} + {$undef ASMVersion} + {$endif} + {$ifndef FPC} + {$define MACOS_OR_KYLIX} + {$endif} +{$endif} + +{Do we require debug info for leak checking?} +{$ifdef RequireDebugInfoForLeakReporting} + {$ifopt D-} + {$undef EnableMemoryLeakReporting} + {$endif} +{$endif} + +{Enable heap checking and leak reporting in full debug mode} +{$ifdef FullDebugMode} + {$define CheckHeapForCorruption} + {$ifndef CatchUseOfFreedInterfaces} + {$define CheckUseOfFreedBlocksOnShutdown} + {$endif} +{$else} + {Error logging requires FullDebugMode} + {$undef LogErrorsToFile} + {$undef CatchUseOfFreedInterfaces} + {$undef RawStackTraces} + {$undef AlwaysAllocateTopDown} +{$endif} + +{Set defines for security options} +{$ifdef FullDebugMode} + {In FullDebugMode small and medium blocks are always cleared when calling + FreeMem. Large blocks are always returned to the OS immediately.} + {$ifdef ClearMemoryBeforeReturningToOS} + {$define ClearLargeBlocksBeforeReturningToOS} + {$endif} + {$ifdef AlwaysClearFreedMemory} + {$define ClearLargeBlocksBeforeReturningToOS} + {$endif} +{$else} + {If memory blocks are cleared in FreeMem then they do not need to be cleared + before returning the memory to the OS.} + {$ifdef AlwaysClearFreedMemory} + {$define ClearSmallAndMediumBlocksInFreeMem} + {$define ClearLargeBlocksBeforeReturningToOS} + {$else} + {$ifdef ClearMemoryBeforeReturningToOS} + {$define ClearMediumBlockPoolsBeforeReturningToOS} + {$define ClearLargeBlocksBeforeReturningToOS} + {$endif} + {$endif} +{$endif} + +{Only the Pascal version supports extended heap corruption checking.} +{$ifdef CheckHeapForCorruption} + {$undef ASMVersion} +{$endif} + +{For BASM bits that are not implemented in 64-bit.} +{$ifdef 32Bit} + {$ifdef ASMVersion} + {$define Use32BitAsm} + {$endif} +{$endif} + +{$ifdef UseRuntimePackages} + {$define AssumeMultiThreaded} +{$endif} + +{$ifdef BCB6OrDelphi6AndUp} + {$WARN SYMBOL_PLATFORM OFF} + {$WARN SYMBOL_DEPRECATED OFF} +{$endif} + +{Leak detail logging requires error logging} +{$ifndef LogErrorsToFile} + {$undef LogMemoryLeakDetailToFile} + {$undef ClearLogFileOnStartup} +{$endif} + +{$ifndef EnableMemoryLeakReporting} + {Manual leak reporting control requires leak reporting to be enabled} + {$undef ManualLeakReportingControl} +{$endif} + +{$ifndef EnableMMX} + {$undef ForceMMX} +{$endif} + +{Are any of the MM sharing options enabled?} +{$ifdef ShareMM} + {$define MMSharingEnabled} +{$endif} +{$ifdef AttemptToUseSharedMM} + {$define MMSharingEnabled} +{$endif} + +{Instruct GExperts to back up the messages file as well.} +{#BACKUP FastMM4Messages.pas} + +{Should debug info be disabled?} +{$ifdef NoDebugInfo} + {$DEBUGINFO OFF} +{$endif} + +{$ifdef BCB} + {$ifdef borlndmmdll} + {$OBJEXPORTALL OFF} + {$endif} + {$ifndef PatchBCBTerminate} + {Cannot uninstall safely under BCB} + {$define NeverUninstall} + {Disable memory leak reporting} + {$undef EnableMemoryLeakReporting} + {$endif} +{$endif} + +{Stack tracer is needed for LogLockContention and for FullDebugMode.} +{$undef _StackTracer} +{$undef _EventLog} +{$ifdef FullDebugMode}{$define _StackTracer}{$define _EventLog}{$endif} +{$ifdef LogLockContention}{$define _StackTracer}{$define _EventLog}{$endif} +{$ifdef UseReleaseStack}{$ifdef DebugReleaseStack}{$define _EventLog}{$endif}{$endif} + + +{$ifndef fpc64bit} + {$ifndef unix} + {$define AllowAsmNoframe} + {$endif} +{$endif} + +{$ifdef AllowAsmNoframe} + {$define AllowAsmParams} +{$endif} + + +{$ifndef POSIX} + {$ifndef FPC} + {$define VmtSupported} + {$endif} +{$endif} + +{$ifndef BCB6OrDelphi7AndUp} + {$ifndef FPC} + {$define SystemRunError} + {$endif} +{$endif} + + +{$ifdef XE2AndUp} +{$define FASTMM4_ALLOW_INLINES} +{$endif} + +{$ifdef FPC} +{$define FASTMM4_ALLOW_INLINES} +{$endif} + +{$ifdef DisableAVX512} +{$undef EnableAVX512} +{$else} +{$define EnableAVX512} +{$endif} + +{$ifdef 32bit} + {$ifdef FPC} + {$define 32bit_SSE} + {$endif} + {$ifdef XE2AndUp} + {$define 32bit_SSE} + {$endif} +{$endif} + +{------------------------Compiler options for FastMM4------------------------} + + +{This is the list of vital compiler options for FastMM4, +don't change them, otherwise FastMM4 would not work. FastMM4 does not support +other values of the options below than set here. The list currently consists +of just one option: "Boolean short-circuit evaluation".} + + + {"BOOLEVAL OFF" means that the compiler generates code for short-circuit + Boolean expression evaluation, which means that evaluation stops as soon + as the result of the entire expression becomes evident in left to right + order of evaluation.} + + {$BOOLEVAL OFF} + +{$ifdef FullDebugMode} + + {The stack framce force copmiler option should be ON for + the FullDebugMode, otherwise the stack unmangling may not work + properly for the call stack debug reports geneated + by FastMM4.} + + {$STACKFRAMES ON} + +{$endif} + +{$ifdef PasCodeAlign} + {$ifdef FPC} + {$CODEALIGN PROC=32} + {$CODEALIGN JUMP=16} + {$CODEALIGN LOOP=8} + {$else} + {$ifdef XE2AndUp} + {$CODEALIGN 16} + {$endif} + {$endif} +{$endif} + +{$ifndef AsmVersion} + {$undef CheckPauseAndSwitchToThreadForAsmVersion} +{$endif} + +{$ifndef DisablePauseAndSwitchToThread} + {$ifdef ASMVersion} + {$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$define FastGetMemNeedPascalCode} + {$define FastGetMemNeedAssemblerCode} + {$else} + {$define FastGetMemNeedAssemblerCode} + {$endif} + {$else} + {$define FastGetMemNeedPascalCode} + {$endif} +{$endif} + +{$ifndef FastGetMemNeedAssemblerCode} +{$undef CheckPauseAndSwitchToThreadForAsmVersion} +{$endif} + +{$ifdef fpc} +{$ifdef 64bit} +{$undef FastGetMemNeedAssemblerCode} +{$define FastGetMemNeedPascalCode} +{$endif} +{$endif} + +{$ifdef FPC} + {$ifdef 64bit} + {$undef ASMVersion} + {Assembler is not yet supportd under 64-bit FreePascal, + because it incorrectly encodes relative values wither with +RIP or without} + {$define AuxAsmRoutines} + {$endif} +{$endif} + +{$ifndef PurePascal} + {$define USE_CPUID} +{$endif} + +{$ifndef DisablePauseAndSwitchToThread} +{$ifndef AssumePauseAndSwitchToThreadAvailable} +{$ifdef USE_CPUID} +{$define AuxAsmRoutines} +{$endif} +{$endif} +{$endif} + +{$ifdef ASMVersion} + {$define FastFreememNeedAssemberCode} + {$define FastReallocMemNeedAssemberCode} +{$endif} + +{$ifndef PurePascal} +{$define AuxAsmRoutines} +{$endif} + +{$ifdef PurePascal} +{$undef USE_CPUID} +{$undef EnableMMX} +{$undef ForceMMX} +{$undef EnableERMS} +{$undef EnableAVX} +{$undef EnableAVX512} +{$undef UseCustomFixedSizeMoveRoutines} +{$undef UseCustomVariableSizeMoveRoutines} +{$define DisableAVX} +{$define DisableAVX1} +{$define DisableAVX2} +{$define DisableAVX512} +{$define Use_GetEnabledXStateFeatures_WindowsAPICall} +{$endif} + +{$ifdef 32bit} +{$define AuxAsmRoutines} +{$endif} + +{$ifdef 64bit} +{$define AuxAsmRoutines} +{$endif} + +{$ifdef EnableAsmCodeAlign} + {$ifdef FPC} + {$define ForceAsmCodeAlign} + {$endif} +{$endif} + +{$ifdef ForceAsmCodeAlign} + {$define AsmCodeAlign} + {$ifdef FPC} + {$define AsmAlNodot} + {$endif} +{$endif} + + +{$ifdef Align16Bytes} +{$define AlignAtLeast16Bytes} +{$endif} + +{$ifdef Align32Bytes} +{$define AlignAtLeast16Bytes} +{$endif} + +{$ifdef FPC} + {$ifdef PurePascal} + {$define SynchroVarLongint} + {$endif} +{$endif} + +{$ifdef PurePascal} + {$undef AsmVersion} + {$undef AuxAsmRoutines} + {$define DisablePauseAndSwitchToThread} +{$endif} + +{$ifdef XE2AndUp} + {$define OperatorsInDefinesSupported} +{$endif} + +{$ifdef FPC} + {$define OperatorsInDefinesSupported} +{$endif} + + +{-------------------------Public constants-----------------------------} +const + {The current version of FastMM4-AVX} + FastMM4AvxVersion = '1.0.6'; + {The current version of FastMM} + FastMMVersion = '4.993'; + + {A bit mask to check memory block alignment in DEBUG mode} +{$ifdef DEBUG} +{$ifdef Align32Bytes} + AlignmentMask = 31; +{$else} + {$ifdef Align16Bytes} + AlignmentMask = 15; + {$else} + AlignmentMask = 7; + {$endif} +{$endif Align32Bytes} +{$endif DEBUG} + + {The number of small block types} +{$ifdef Align32Bytes} + NumSmallBlockTypes = 44; +{$else} +{$ifdef Align16Bytes} + NumSmallBlockTypes = 46; +{$else} + NumSmallBlockTypes = 56; +{$endif} +{$endif} + + +{----------------------------Public types------------------------------} +type + + {Make sure all the required types are available} +{$ifdef BCB6OrDelphi6AndUp} + {$if CompilerVersion < 20} + PByte = PAnsiChar; {$define PByteIsPAnsiChar} + {NativeInt didn't exist or was broken before Delphi 2009.} + NativeInt = Integer; + {$ifend} + {$if CompilerVersion < 21} + {NativeUInt didn't exist or was broken before Delphi 2010.} + NativeUInt = Cardinal; + {$ifend} + {$if CompilerVersion < 22} + {PNativeUInt didn't exist before Delphi XE.} + PNativeUInt = ^Cardinal; + {$ifend} + {$if CompilerVersion < 23} + {IntPtr and UIntPtr didn't exist before Delphi XE2.} + IntPtr = Integer; + UIntPtr = Cardinal; + {$ifend} +{$else} + {$ifndef fpc} + PByte = PAnsiChar; {$define PByteIsPAnsiChar} + NativeInt = Integer; + NativeUInt = Cardinal; + PNativeUInt = ^Cardinal; + IntPtr = Integer; + UIntPtr = Cardinal; + {$else} + NativeUInt = PtrUInt; + PNativeUInt = ^PtrUInt; + {$endif} +{$endif} + + TSmallBlockTypeState = record + {The internal size of the block type} + InternalBlockSize: Cardinal; + {Useable block size: The number of non-reserved bytes inside the block.} + UseableBlockSize: Cardinal; + {The number of allocated blocks} + AllocatedBlockCount: NativeUInt; + {The total address space reserved for this block type (both allocated and + free blocks)} + ReservedAddressSpace: NativeUInt; + end; + TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState; + + TMemoryManagerState = record + {Small block type states} + SmallBlockTypeStates: TSmallBlockTypeStates; + {Medium block stats} + AllocatedMediumBlockCount: Cardinal; + TotalAllocatedMediumBlockSize: NativeUInt; + ReservedMediumBlockAddressSpace: NativeUInt; + {Large block stats} + AllocatedLargeBlockCount: Cardinal; + TotalAllocatedLargeBlockSize: NativeUInt; + ReservedLargeBlockAddressSpace: NativeUInt; + end; + + TMemoryManagerUsageSummary = record + {The total number of bytes allocated by the application.} + AllocatedBytes: NativeUInt; + {The total number of address space bytes used by control structures, or + lost due to fragmentation and other overhead.} + OverheadBytes: NativeUInt; + {The efficiency of the memory manager expressed as a percentage. This is + 100 * AllocatedBytes / (AllocatedBytes + OverheadBytes).} + EfficiencyPercentage: Double; + end; + + {Memory map} + TChunkStatus = (csUnallocated, csAllocated, csReserved, csSysAllocated, + csSysReserved); + TMemoryMap = array[0..65535] of TChunkStatus; + +{$ifdef EnableMemoryLeakReporting} + {List of registered leaks} + TRegisteredMemoryLeak = record + LeakAddress: Pointer; + LeakedClass: TClass; + {$ifdef CheckCppObjectTypeEnabled} + LeakedCppTypeIdPtr: Pointer; + {$endif} + LeakSize: NativeInt; + LeakCount: Integer; + end; + TRegisteredMemoryLeaks = array of TRegisteredMemoryLeak; +{$endif} + + {Used by the DetectStringData routine to detect whether a leaked block + contains string data.} + TStringDataType = (stUnknown, stAnsiString, stUnicodeString); + + {The callback procedure for WalkAllocatedBlocks.} + TWalkAllocatedBlocksCallback = procedure(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer); + + TFastMM_MemoryManagerInstallationState = ( + {The default memory manager is currently in use.} + mmisDefaultMemoryManagerInUse, + {Another third party memory manager has been installed.} + mmisOtherThirdPartyMemoryManagerInstalled, + {A shared memory manager is being used.} + mmisUsingSharedMemoryManager, + {This memory manager has been installed.} + mmisInstalled); + +{--------------------------Public variables----------------------------} +var + {If this variable is set to true and FullDebugMode is enabled, then the + entire memory pool is checked for consistency before every memory + operation. Note that this incurs a massive performance hit on top of + the already significant FullDebugMode overhead, so enable this option + only when absolutely necessary.} + FullDebugModeScanMemoryPoolBeforeEveryOperation: Boolean; + FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak: Boolean; +{$ifdef ManualLeakReportingControl} + {Variable is declared in system.pas in newer Delphi versions.} + {$ifndef BDS2006AndUp} + ReportMemoryLeaksOnShutdown: Boolean; + {$endif} +{$endif} + {If set to True, disables the display of all messageboxes} + SuppressMessageBoxes: Boolean; + +{-------------------------Public procedures----------------------------} +{Executes the code normally run in the initialization section. Running it + earlier may be required with e.g. some software protection tools.} +procedure RunInitializationCode; +{Installation procedures must be exposed for the BCB helper unit FastMM4BCB.cpp} +{$ifdef BCB} +procedure InitializeMemoryManager; +function CheckCanInstallMemoryManager: Boolean; +procedure InstallMemoryManager; + +{$ifdef FullDebugMode} +(*$HPPEMIT '#define FullDebugMode' *) + +{$ifdef ClearLogFileOnStartup} +(*$HPPEMIT ' #define ClearLogFileOnStartup' *) +procedure DeleteEventLog; +{$endif} + +{$ifdef LoadDebugDLLDynamically} +(*$HPPEMIT ' #define LoadDebugDLLDynamically' *) +{$endif} + +{$ifdef RawStackTraces} +(*$HPPEMIT ' #define RawStackTraces' *) +{$endif} + +{$endif} + +{$ifdef PatchBCBTerminate} +(*$HPPEMIT ''#13#10 *) +(*$HPPEMIT '#define PatchBCBTerminate' *) + +{$ifdef EnableMemoryLeakReporting} +(*$HPPEMIT ''#13#10 *) +(*$HPPEMIT '#define EnableMemoryLeakReporting' *) +{$endif} + +{$ifdef DetectMMOperationsAfterUninstall} +(*$HPPEMIT ''#13#10 *) +(*$HPPEMIT '#define DetectMMOperationsAfterUninstall' *) +{$endif} + +{Called in FastMM4BCB.cpp, should contain codes of original "finalization" section} +procedure FinalizeMemoryManager; + +{For completion of "RequireDebuggerPresenceForLeakReporting" checking in "FinalizeMemoryManager"} +var + pCppDebugHook: ^Integer = nil; //PInteger not defined in BCB5 + +{$ifdef CheckCppObjectTypeEnabled} +(*$HPPEMIT ''#13#10 *) +(*$HPPEMIT '#define CheckCppObjectTypeEnabled' *) + +type + TGetCppVirtObjSizeByTypeIdPtrFunc = function(APointer: Pointer): Cardinal; + TGetCppVirtObjTypeIdPtrFunc = function(APointer: Pointer; ASize: Cardinal): Pointer; + TGetCppVirtObjTypeNameFunc = function(APointer: Pointer; ASize: Cardinal): PAnsiChar; + TGetCppVirtObjTypeNameByTypeIdPtrFunc = function (APointer: Pointer): PAnsiChar; + TGetCppVirtObjTypeNameByVTablePtrFunc = function(AVTablePtr: Pointer; AVTablePtrOffset: Cardinal): PAnsiChar; +var + {Return virtual object's size from typeId pointer} + GetCppVirtObjSizeByTypeIdPtrFunc: TGetCppVirtObjSizeByTypeIdPtrFunc = nil; + {Retrieve virtual object's typeId pointer} + GetCppVirtObjTypeIdPtrFunc: TGetCppVirtObjTypeIdPtrFunc = nil; + {Retrieve virtual object's type name} + GetCppVirtObjTypeNameFunc: TGetCppVirtObjTypeNameFunc = nil; + {Return virtual object's type name from typeId pointer} + GetCppVirtObjTypeNameByTypeIdPtrFunc: TGetCppVirtObjTypeNameByTypeIdPtrFunc = nil; + {Retrieve virtual object's typeId pointer from it's virtual table pointer} + GetCppVirtObjTypeNameByVTablePtrFunc: TGetCppVirtObjTypeNameByVTablePtrFunc = nil; +{$endif} +{$endif} +{$endif} + +{$ifndef FullDebugMode} +{The standard memory manager functions} +function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; +function FastFreeMem(APointer: Pointer): {$ifdef fpc}{$ifdef CPU64}PtrUInt{$else}NativeUInt{$endif}{$else}Integer{$endif}; +function FastReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; +function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Cardinal{$endif}{$endif}): Pointer; +{$else} +{The FullDebugMode memory manager functions} +function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +function DebugFreeMem(APointer: Pointer): Integer; +function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; +{Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is + raised.} +procedure ScanMemoryPoolForCorruptions; +{Returns the current "allocation group". Whenever a GetMem request is serviced + in FullDebugMode, the current "allocation group" is stored in the block header. + This may help with debugging. Note that if a block is subsequently reallocated + that it keeps its original "allocation group" and "allocation number" (all + allocations are also numbered sequentially).} +function GetCurrentAllocationGroup: Cardinal; +{Allocation groups work in a stack like fashion. Group numbers are pushed onto + and popped off the stack. Note that the stack size is limited, so every push + should have a matching pop.} +procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal); +procedure PopAllocationGroup; +{Logs detail about currently allocated memory blocks for the specified range of + allocation groups. if ALastAllocationGroupToLog is less than + AFirstAllocationGroupToLog or it is zero, then all allocation groups are + logged. This routine also checks the memory pool for consistency at the same + time, raising an "Out of Memory" error if the check fails.} +procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal); +{$endif} +{$ifdef _EventLog} +{Specify the full path and name for the filename to be used for logging memory + errors, etc. If ALogFileName is nil or points to an empty string it will + revert to the default log file name.} +procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil); +{$endif} + +{Releases all allocated memory (use with extreme care)} +procedure FreeAllMemory; + +{Returns summarised information about the state of the memory manager. (For + backward compatibility.)} +function FastGetHeapStatus: THeapStatus; +{Returns statistics about the current state of the memory manager} +procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); +{Returns a summary of the information returned by GetMemoryManagerState} +function GetMemoryManagerUsageSummary: TMemoryManagerUsageSummary; overload; +procedure GetMemoryManagerUsageSummary(var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary); overload; +{$ifndef POSIX} +{Gets the state of every 64K block in the 4GB address space} +procedure GetMemoryMap(var AMemoryMap: TMemoryMap); +{$endif} +{Returns the current installation state of the memory manager.} +function FastMM_GetInstallationState: TFastMM_MemoryManagerInstallationState; + +{$ifdef EnableMemoryLeakReporting} +{Registers expected memory leaks. Returns true on success. The list of leaked + blocks is limited, so failure is possible if the list is full.} +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; +{$ifdef CheckCppObjectTypeEnabled} +{Registers expected memory leaks by virtual object's typeId pointer. + Usage: RegisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);} +function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload; +{$endif} +{Removes expected memory leaks. Returns true on success.} +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; +{$ifdef CheckCppObjectTypeEnabled} +{Usage: UnregisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);} +function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload; +{$endif} +{Returns a list of all expected memory leaks} +function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks; +{$endif} + +{Returns the class for a memory block. Returns nil if it is not a valid class. + Used by the leak detection code.} +function DetectClassInstance(APointer: Pointer): TClass; +{Detects the probable string data type for a memory block. Used by the leak + classification code when a block cannot be identified as a known class + instance.} +function DetectStringData(APMemoryBlock: Pointer; + AAvailableSpaceInBlock: NativeInt): TStringDataType; +{Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback. + Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.} +procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer); +{Writes a log file containing a summary of the memory manager state and a summary of allocated blocks grouped by + class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. } +function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string = ''): Boolean; + +{$ifdef UseReleaseStack} +{$ifdef DebugReleaseStack} +procedure LogReleaseStackUsage; +{$endif} +{$endif} + +{$ifdef _StackTracer} +{------------- FullDebugMode/LogLockContention constants---------------} +const + {The stack trace depth. (Must be an *uneven* number to ensure that the + Align16Bytes option works in FullDebugMode.)} + StackTraceDepth = 11; + +type + PStackTrace = ^TStackTrace; + TStackTrace = array[0..StackTraceDepth - 1] of NativeUInt; +{$endif} + +{$ifdef FullDebugMode} +{-------------FullDebugMode constants---------------} +const + {The number of entries in the allocation group stack} + AllocationGroupStackSize = 1000; + {The number of fake VMT entries - used to track virtual method calls on + freed objects. Do not change this value without also updating TFreedObject.GetVirtualMethodIndex} + MaxFakeVMTEntries = 200; + {The pattern used to fill unused memory} + DebugFillByte = $80; +{$ifdef 32Bit} + DebugFillPattern = $01010101 * Cardinal(DebugFillByte); // Default value $80808080 + {The address that is reserved so that accesses to the address of the fill + pattern will result in an A/V. (Not used under 64-bit, since the upper half + of the address space is always reserved by the OS.)} + DebugReservedAddress = $01010000 * Cardinal(DebugFillByte); // Default value $80800000 +{$else} + DebugFillPattern = $8080808080808080; +{$endif} + {The number of bytes of address space that cannot be allocated under FullDebugMode. This block is reserved on + startup and freed the first time the system runs out of address space. This allows some subsequent memory allocation + requests to succeed in order to allow the application to allocate some memory for error handling, etc. in response to + the first EOutOfMemory exception.} + FullDebugModeAddressSpaceSlack = 5 * 1024 * 1024; + +{-------------------------FullDebugMode structures--------------------} +type + TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem); + + {The header placed in front of blocks in FullDebugMode (just after the + standard header). Must be a multiple of 16 bytes in size otherwise the + Align16Bytes option will not work. Current size = 128 bytes under 32-bit, + and 240 bytes under 64-bit.} + PFullDebugBlockHeader = ^TFullDebugBlockHeader; + TFullDebugBlockHeader = record + {Space used by the medium block manager for previous/next block management. + If a medium block is binned then these two fields will be modified.} + Reserved1: Pointer; + Reserved2: Pointer; + {Is the block currently allocated? If it is allocated this will be the + address of the getmem routine through which it was allocated, otherwise it + will be nil.} + AllocatedByRoutine: Pointer; + {The allocation group: Can be used in the debugging process to group + related memory leaks together} + AllocationGroup: Cardinal; + {The allocation number: All new allocations are numbered sequentially. This + number may be useful in memory leak analysis. If it reaches 4G it wraps + back to 0.} + AllocationNumber: Cardinal; + {The call stack when the block was allocated} + AllocationStackTrace: TStackTrace; + {The thread that allocated the block} + AllocatedByThread: Cardinal; + {The thread that freed the block} + FreedByThread: Cardinal; + {The call stack when the block was freed} + FreeStackTrace: TStackTrace; + {The user requested size for the block. 0 if this is the first time the + block is used.} + UserSize: NativeUInt; + {The object class this block was used for the previous time it was + allocated. When a block is freed, the pointer that would normally be in the + space of the class pointer is copied here, so if it is detected that + the block was used after being freed we have an idea what class it is.} + PreviouslyUsedByClass: NativeUInt; + {The sum of all the dwords(32-bit)/qwords(64-bit) in this structure + excluding the initial two reserved fields and this field.} + HeaderCheckSum: NativeUInt; + end; + {The NativeUInt following the user area of the block is the inverse of + HeaderCheckSum. This is used to catch buffer overrun errors.} + + {The class used to catch attempts to execute a virtual method of a freed + object} + TFreedObject = class + public + procedure GetVirtualMethodIndex; + procedure VirtualMethodError; +{$ifdef CatchUseOfFreedInterfaces} + procedure InterfaceError; +{$endif} + end; + +{$ifdef FullDebugModeCallBacks} + {FullDebugMode memory manager event callbacks. Note that APHeaderFreedBlock in the TOnDebugFreeMemFinish + will not be valid for large (>260K) blocks.} + TOnDebugGetMemFinish = procedure(APHeaderNewBlock: PFullDebugBlockHeader; ASize: NativeInt); + TOnDebugFreeMemStart = procedure(APHeaderBlockToFree: PFullDebugBlockHeader); + TOnDebugFreeMemFinish = procedure(APHeaderFreedBlock: PFullDebugBlockHeader; AResult: Integer); + TOnDebugReallocMemStart = procedure(APHeaderBlockToReallocate: PFullDebugBlockHeader; ANewSize: NativeInt); + TOnDebugReallocMemFinish = procedure(APHeaderReallocatedBlock: PFullDebugBlockHeader; ANewSize: NativeInt); + +var + {Note: FastMM will not catch exceptions inside these hooks, so make sure your hook code runs without + exceptions.} + OnDebugGetMemFinish: TOnDebugGetMemFinish = nil; + OnDebugFreeMemStart: TOnDebugFreeMemStart = nil; + OnDebugFreeMemFinish: TOnDebugFreeMemFinish = nil; + OnDebugReallocMemStart: TOnDebugReallocMemStart = nil; + OnDebugReallocMemFinish: TOnDebugReallocMemFinish = nil; +{$endif} +{$endif} + +implementation + +uses +{$ifndef POSIX} + Windows, + {$ifdef _EventLog} + {$ifdef Delphi4or5} + ShlObj, + {$else} + SHFolder, + {$endif} + {$endif} +{$else} + {$ifdef MACOS} + Posix.Stdlib, Posix.Unistd, Posix.Fcntl, Posix.PThread, FastMM_OSXUtil, + {$else} + {$ifdef fpc} + BaseUnix, + {$else} + Libc, + {$endif} + {$endif} +{$endif} +{$ifdef LogLockContention} + FastMM4DataCollector, +{$endif} +{$ifdef UseReleaseStack} + FastMM4LockFreeStack, +{$endif} + FastMM4Messages; + +const + MaxFileNameLength = 1024; + {The MaxFileNameLengthDouble value is extracted from the FastMM4 code + as an effort to replace all "magic" (unnamed numerical constants) with + theier named counterparts. We have yet to igure out why some file names + reserve a buffer of 1024 characters while some other file names reserve + double of that} {todo: MaxFileNameLengthDouble figure out - see the comment} + MaxFileNameLengthDouble = MaxFileNameLength*2; + MaxDisplayMessageLength = 1024; + MaxLogMessageLength = 32768; + +{$ifdef fpc} +const + clib = 'c'; + +function valloc(__size:size_t):pointer;cdecl;external clib name 'valloc'; +procedure free(__ptr:pointer);cdecl;external clib name 'free'; +function usleep(__useconds:dword):longint;cdecl;external clib name 'usleep'; +{$endif} + +{Fixed size move procedures. The 64-bit versions assume 16-byte alignment.} +{$ifdef 64bit} +{$ifdef Align32Bytes} + {Used to exclude the procedures that we don't need, from compiling, to not + rely on the "smart" linker to do this job for us} + {$define ExcludeSmallGranularMoves} +{$endif} +{$endif} + +{$ifdef UseCustomFixedSizeMoveRoutines} + +{$ifndef ExcludeSmallGranularMoves} +procedure Move4(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move12(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move20(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move28(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move36(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move44(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move52(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move60(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move68(const ASource; var ADest; ACount: NativeInt); forward; +{$endif} + +{$ifdef 64Bit} +{These are not needed and thus unimplemented under 32-bit} +{$ifndef ExcludeSmallGranularMoves} +procedure Move8(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move16(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move24(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move32(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move40(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move48(const ASource; var ADest; ACount: NativeInt); forward; +{$endif} +procedure Move56(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move64(const ASource; var ADest; ACount: NativeInt); forward; +{$endif} + +{$endif UseCustomFixedSizeMoveRoutines} + +{$ifdef DetectMMOperationsAfterUninstall} +{Invalid handlers to catch MM operations after uninstall} +function InvalidFreeMem(APointer: Pointer): {$ifdef fpc}NativeUInt{$else}Integer{$endif}; forward; +function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; forward; +function InvalidReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; forward; +function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUint{$else}Cardinal{$endif}{$endif}): Pointer; forward; +function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; forward; +{$endif} + +{-------------------------Private constants----------------------------} + +const + +{$ifdef Align32Bytes} + MediumBlockSizeOffset = 64; +{$else} + MediumBlockSizeOffset = 48; +{$endif} + + {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 (or 32, depending on alignment) and at + least "SizeOf(Pointer)" bytes less than a multiple of 4K (the page size) to + prevent a possible read access violation when reading past the end of a + memory block in the optimized move routine (MoveX16LP/MoveX32LP). + 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} + {$ifdef Align32Bytes} + 32 + {$else} + 16 + {$endif Align32Bytes} + {$else} + 256 + {$endif FullDebugMode}; + + UnsignedBit = NativeUInt(1); + + + {According to the Intel 64 and IA-32 Architectures Software Developers Manual, + p. 3.7.5 (Specifying an Offset) and 3.7.5.1 (Specifying an Offset in 64-Bit Mode): + "Scale factor - A value of 2, 4, or 8 that is multiplied by the index value"; + The value of MaximumCpuScaleFactor is determined by the processor architecture} + MaximumCpuScaleFactorPowerOf2 = 3; + MaximumCpuScaleFactor = Byte(UnsignedBit shl MaximumCpuScaleFactorPowerOf2); + {The granularity of small blocks} +{$ifdef Align32Bytes} + SmallBlockGranularityPowerOf2 = 5; +{$else} +{$ifdef Align16Bytes} + SmallBlockGranularityPowerOf2 = 4; +{$else} + SmallBlockGranularityPowerOf2 = 3; +{$endif} +{$endif} + SmallBlockGranularity = Byte(UnsignedBit shl SmallBlockGranularityPowerOf2); + + + {The granularity of medium blocks. Newly allocated medium blocks are + a multiple of this size plus MediumBlockSizeOffset, to avoid cache line + conflicts} + MediumBlockGranularityPowerOf2 = 8; + MediumBlockGranularity = UnsignedBit shl MediumBlockGranularityPowerOf2; + MediumBlockGranularityMask = NativeUInt(-NativeInt(MediumBlockGranularity)); + + {The granularity of large blocks} + LargeBlockGranularity = 65536; + {The maximum size of a small block. Blocks Larger than this are either + medium or large blocks.} + LargeBlockGranularityMask = NativeUInt(-LargeBlockGranularity); + +{$ifdef Align32Bytes} + MaximumSmallBlockSize = 2624; +{$else} + MaximumSmallBlockSize = 2608; +{$endif} + + {The smallest medium block size. (Medium blocks are rounded up to the nearest + multiple of MediumBlockGranularity plus MediumBlockSizeOffset)} + MinimumMediumBlockSize = 11 * MediumBlockGranularity + MediumBlockSizeOffset; + + {$ifdef OperatorsInDefinesSupported} + {$if (MaximumSmallBlockSize mod SmallBlockGranularity) <> 0 } + {$Message Fatal 'Invalid MaximumSmallBlockSize granularity'} + {$ifend} + {$endif} + + {The number of bins reserved for medium blocks} + MediumBlockBinsPerGroupPowerOf2 = 5; + {Must be a power of 2, otherwise masks would not work} + MediumBlockBinsPerGroup = Byte(UnsignedBit shl MediumBlockBinsPerGroupPowerOf2); + 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 - Cardinal(MediumBlockGranularity) + MediumBlockSizeOffset; + OptimalSmallBlockPoolSizeUpperLimit = 64 * 1024 - Cardinal(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 = NativeUint(-8); + {$ifdef CheckHeapForCorruption} + ExtractSmallFlagsMask = NativeUint(7); + {$endif} + {The flags masks for medium and large blocks} +{$ifdef Align32Bytes} + DropMediumAndLargeFlagsMask = -32; + ExtractMediumAndLargeFlagsMask = 31; +{$else} + DropMediumAndLargeFlagsMask = -16; + ExtractMediumAndLargeFlagsMask = 15; +{$endif} + {-------------Block resizing constants---------------} + {The upsize and downsize checker must a a multiple of the granularity, + otherwise on big-granularity and small upsize/downsize constant values, + reallocating 1-byte blocks, keeping the same size as before, will return + different pointer, and, as a result, the FastCode validation suite + will not pass} + SmallBlockDownsizeCheckAdder = SmallBlockGranularity*4; + SmallBlockUpsizeAdder = SmallBlockGranularity*2; + {When a medium block is reallocated to a size smaller than this, then it must + be reallocated to a small block and the data moved. If not, then it is + shrunk in place down to MinimumMediumBlockSize. Currently the limit is set + at a quarter of the minimum medium block size.} + MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4; + {-------------Memory leak reporting constants---------------} + ExpectedMemoryLeaksListSize = 64 * 1024; + {-------------Other constants---------------} +{$ifndef NeverSleepOnThreadContention} + {Sleep time when a resource (small/medium/large block manager) is in use} + InitialSleepTime = 0; + {Used when the resource is still in use after the first sleep} + AdditionalSleepTime = 1; +{$endif} + {Hexadecimal characters} + HexTable: array[0..15] of AnsiChar = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); +{$ifdef FullDebugMode} + {Virtual Method Called On Freed Object Errors} + StandardVirtualMethodNames: array[1 + vmtParent div SizeOf(Pointer) .. vmtDestroy div SizeOf(Pointer)] of PAnsiChar = ( +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + 'Equals', + 'GetHashCode', + 'ToString', + {$ifend} +{$endif} + 'SafeCallException', + 'AfterConstruction', + 'BeforeDestruction', + 'Dispatch', + 'DefaultHandler', + 'NewInstance', + 'FreeInstance', + 'Destroy'); + {The name of the FullDebugMode support DLL. The support DLL implements stack + tracing and the conversion of addresses to unit and line number information.} +{$endif} +{$ifdef UseReleaseStack} + ReleaseStackSize = 16; + NumStacksPerBlock = 64; //should be power of 2 +{$endif} + +{$ifdef _StackTracer} +{$ifdef 32Bit} + FullDebugModeLibraryName = FullDebugModeLibraryName32Bit; +{$else} + FullDebugModeLibraryName = FullDebugModeLibraryName64Bit; +{$endif} +{$endif} + +{$ifdef Delphi4or5} + reInvalidOp = 217; +{$endif} + + +{-------------------------Private types----------------------------} +type + +{$ifdef Delphi4or5} + {Delphi 5 Compatibility} + PCardinal = ^Cardinal; + PPointer = ^Pointer; +{$endif} +{$ifdef BCB4} + {Define some additional types for BCB4} + PInteger = ^Integer; +{$endif} + + {Move procedure type} + TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt); + +{$ifdef USE_CPUID} + {Registers structure (for GetCPUID) + The registers are used solely for the CPUID instruction, + thus they are always 32-bit, even under 64-bit mode} + TCpuIdRegisters = record + RegEAX, RegEBX, RegECX, RegEDX: Cardinal; + end; +{$endif} + + {The layout of a string allocation. Used to detect string leaks.} + PStrRec = ^StrRec; + StrRec = packed record +{$ifdef 64Bit} + _Padding: Integer; +{$endif} +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + codePage: Word; + elemSize: Word; + {$ifend} +{$endif} + refCnt: Integer; + length: Integer; + end; + +{$ifdef EnableMemoryLeakReporting} + {Different kinds of memory leaks} + TMemoryLeakType = (mltUnexpectedLeak, mltExpectedLeakRegisteredByPointer, + mltExpectedLeakRegisteredByClass, mltExpectedLeakRegisteredBySize); +{$endif} + + TSynchronizationVariable = + {$ifdef SynchroVarLongint} + LongInt + {$else} + {$ifdef XE2AndUp} + System.ShortInt + {$else} + Byte + {$endif} + {$endif} + ; + + {---------------Small block structures-------------} + + {Pointer to the header of a small block pool} + PSmallBlockPoolHeader = ^TSmallBlockPoolHeader; + + {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).} + PSmallBlockType = ^TSmallBlockType; + TSmallBlockType = record + {True = Block type is locked} + + SmallBlockTypeLocked: TSynchronizationVariable; {The type is Byte for strict + type checking when the typed "@" operator + compiler option is ON.} + + {Bitmap indicating which of the first 8 medium block groups contain blocks + of a suitable size for a block pool.} + AllowedGroupsForBlockPoolBitmap: Byte; +{$ifdef SynchroVarLongint} + Reserved2: Byte; +{$endif} + {The block size for this block type} + BlockSize: Word; + {The minimum and optimal size of a small block pool for this block type} + MinimumBlockPoolSize: Word; + OptimalBlockPoolSize: Word; + {The first partially free pool for the given small block. This field must + be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.} + NextPartiallyFreePool: PSmallBlockPoolHeader; + {The last partially free pool for the small block type. This field must + be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.} + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {The offset of the last block that was served sequentially. The field must + be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.} + NextSequentialFeedBlockAddress: Pointer; + {The last block that can be served sequentially.} + MaxSequentialFeedBlockAddress: Pointer; + {The pool that is current being used to serve blocks in sequential order} + CurrentSequentialFeedPool: PSmallBlockPoolHeader; +{$ifdef UseCustomFixedSizeMoveRoutines} + {The fixed size move procedure used to move data for this block size when + it is upsized. When a block is downsized (which usually does not occur + that often) the variable size move routine is used.} + UpsizeMoveProcedure: TMoveProc; +{$else} + {$ifndef SynchroVarLongint} + Reserved1: Pointer; + {$endif} +{$endif} + {$ifdef 64bit} + Reserved3: Pointer; + {$endif} +{$ifdef UseReleaseStack} + ReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack; +{$endif} +{$ifdef LogLockContention} + BlockCollector: TStaticCollector; +{$endif} + end; + + {Small block pool (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).} + TSmallBlockPoolHeader = record + {BlockType} + BlockType: PSmallBlockType; +{$ifdef 32Bit} + {Align the next fields to the same fields in TSmallBlockType and pad this + structure to 32 bytes for 32-bit} + Reserved1: Cardinal; +{$endif} + {The next and previous pool that has free blocks of this size. Do not + change the position of these two fields: They must be at the same offsets + as the fields in TSmallBlockType of the same name.} + NextPartiallyFreePool: PSmallBlockPoolHeader; + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {Pointer to the first free block inside this pool. This field must be at + the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.} + FirstFreeBlock: Pointer; + {The number of blocks allocated in this pool.} + BlocksInUse: Cardinal; + {Padding} + Reserved2: Cardinal; + {The pool pointer and flags of the first block} + FirstBlockPoolPointerAndFlags: NativeUInt; +{$ifdef 64bit} + Reserved3, Reserved4: Pointer; // Align the structure to 64-bit size +{$endif} + end; + + {Small block layout: + At offset -SizeOf(Pointer) = Flags + address of the small block pool. + At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block + pool for the next small block. + } + + {------------------------Medium block structures------------------------} + + {The medium block pool from which medium blocks are drawn. Size = 16 bytes + for 32-bit and 32 bytes for 64-bit.} + PMediumBlockPoolHeader = ^TMediumBlockPoolHeader; + TMediumBlockPoolHeader = record + {Points to the previous and next medium block pools. This circular linked + list is used to track memory leaks on program shutdown.} + PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader; + NextMediumBlockPoolHeader: PMediumBlockPoolHeader; + {Padding} + Reserved1: NativeUInt; + {$ifdef 32bit} + {$ifdef Align32Bytes} + Reserved2, Reserved3, Reserved4, Reserved5: Pointer; + {$endif} + {$endif} + {The block size and flags of the first medium block in the block pool} + FirstMediumBlockSizeAndFlags: NativeUInt; + end; + + {Medium block layout: + Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free) + Offset: -SizeOf(Pointer) = This block size and flags + Offset: 0 = User data / Previous Free Block (if this block is free) + Offset: SizeOf(Pointer) = Next Free Block (if this block is free) + Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free) + Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags} + + {A medium block that is unused} + PMediumFreeBlock = ^TMediumFreeBlock; + TMediumFreeBlock = record + PreviousFreeBlock: PMediumFreeBlock; + NextFreeBlock: PMediumFreeBlock; + end; + + {-------------------------Large block structures------------------------} + + {Large block header record (Size = 16 for 32-bit unless we have 32-bytes alignment, 32 for 64-bit or if we have 32-bytes alignment)} + PLargeBlockHeader = ^TLargeBlockHeader; + TLargeBlockHeader = record + {Points to the previous and next large blocks. This circular linked + list is used to track memory leaks on program shutdown.} + PreviousLargeBlockHeader: PLargeBlockHeader; + NextLargeBlockHeader: PLargeBlockHeader; + {$ifdef 32bit} + {$ifdef Align32Bytes} + Reserved1, Reserved2, Reserved3, Reserved4: Pointer; + {$endif} + {$endif} + {The user allocated size of the Large block} + UserAllocatedSize: NativeUInt; + {The size of this block plus the flags} + BlockSizeAndFlags: NativeUInt; + end; + + {-------------------------Expected Memory Leak Structures--------------------} +{$ifdef EnableMemoryLeakReporting} + + {The layout of an expected leak. All fields may not be specified, in which + case it may be harder to determine which leaks are expected and which are + not.} + PExpectedMemoryLeak = ^TExpectedMemoryLeak; + PPExpectedMemoryLeak = ^PExpectedMemoryLeak; + TExpectedMemoryLeak = record + {Linked list pointers} + PreviousLeak, NextLeak: PExpectedMemoryLeak; + {Information about the expected leak} + LeakAddress: Pointer; + LeakedClass: TClass; + {$ifdef CheckCppObjectTypeEnabled} + LeakedCppTypeIdPtr: Pointer; + {$endif} + LeakSize: NativeInt; + LeakCount: Integer; + end; + + TExpectedMemoryLeaks = record + {The number of entries used in the expected leaks buffer} + EntriesUsed: Integer; + {Freed entries} + FirstFreeSlot: PExpectedMemoryLeak; + {Entries with the address specified} + FirstEntryByAddress: PExpectedMemoryLeak; + {Entries with no address specified, but with the class specified} + FirstEntryByClass: PExpectedMemoryLeak; + {Entries with only size specified} + FirstEntryBySizeOnly: PExpectedMemoryLeak; + {The expected leaks buffer (Need to leave space for this header)} + ExpectedLeaks: array[0..(ExpectedMemoryLeaksListSize - 64) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak; + end; + PExpectedMemoryLeaks = ^TExpectedMemoryLeaks; + +{$endif} + +{-------------------------Private constants----------------------------} +const + {$ifdef 32bit} + MediumFreeBlockSizePowerOf2 = 3; + {$else} + MediumFreeBlockSizePowerOf2 = 4; + {$endif} + + {$ifdef OperatorsInDefinesSupported} + {$if 1 shl MediumFreeBlockSizePowerOf2 <> SizeOf(TMediumFreeBlock)} + {$Message Fatal 'Invalid MediumFreeBlockSizePowerOf2 constant or SizeOf(TMediumFreeBlock) is not a power of 2'} + {$ifend} + {$endif} + +{$ifndef LogLockContention} + {$define SmallBlockTypeRecSizeIsPowerOf2} +{$endif} + +{$ifndef SmallBlockTypeRecSizeIsPowerOf2} + SmallBlockTypeRecSize = SizeOf(TSmallBlockType); +{$endif} + +{$ifdef SmallBlockTypeRecSizeIsPowerOf2} + {$ifdef 32bit} + SmallBlockTypeRecSizePowerOf2 = 5; + {$endif} + {$ifdef 64bit} + SmallBlockTypeRecSizePowerOf2 = 6; + {$endif} + SmallBlockTypeRecSize = Byte(UnsignedBit shl SmallBlockTypeRecSizePowerOf2); +{$endif} + +{$ifndef UseReleaseStack} + {$ifdef OperatorsInDefinesSupported} + {$if SmallBlockTypeRecSize <> SizeOf(TSmallBlockType)} + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + {$Message Fatal 'Invalid SmallBlockTypeRecSizePowerOf2 constant or SizeOf(TSmallBlockType) is not a power of 2'} + {$endif} + {$ifend} + {$endif} +{$endif} + +{$ifndef BCB6OrDelphi7AndUp} + reOutOfMemory = 1; + reInvalidPtr = 2; +{$endif} + {The size of the block header in front of small and medium blocks} + BlockHeaderSize = SizeOf(Pointer); + + {The size of a small block pool header: 32 bytes for 32-bit, 64 bytes for 64-bit).} + SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader); + {$ifdef OperatorsInDefinesSupported} + {$ifdef 32bit} + {$if SmallBlockPoolHeaderSize <> 32} + {$Message Fatal 'SmallBlockPoolHeaderSize should be 32 bytes for 32-bit'} + {$ifend} + {$else} + {$if SmallBlockPoolHeaderSize <> 64} + {$Message Fatal 'SmallBlockPoolHeaderSize should be 64 bytes for 64-bit'} + {$ifend} + {$endif} + {$endif} + + {The size of a medium block pool header: 16 bytes for 32-bit and 32 bytes for 64-bit.} + MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader); + {$ifdef OperatorsInDefinesSupported} + {$ifdef 32bit} + {$ifdef Align32Bytes} + {$if MediumBlockPoolHeaderSize <> 32} + {$Message Fatal 'MediumBlockPoolHeaderSize should be 32 bytes for 32-bit with 32-bytes alignment'} + {$ifend} + {$else} + {$if MediumBlockPoolHeaderSize <> 16} + {$Message Fatal 'MediumBlockPoolHeaderSize should be 16 bytes for 32-bit unless we have 32-bytes alignment'} + {$ifend} + {$endif} + {$else} + {$if MediumBlockPoolHeaderSize <> 32} + {$Message Fatal 'MediumBlockPoolHeaderSize should be 32 bytes for 64-bit'} + {$ifend} + {$endif} + {$endif} + + {The size of the header in front of Large blocks} + LargeBlockHeaderSize = SizeOf(TLargeBlockHeader); +{$ifdef FullDebugMode} + {We need space for the header, the trailer checksum and the trailing block + size (only used by freed medium blocks).} + FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt) + SizeOf(Pointer); +{$endif} + + + {The distinction between AVX1 and AVX2 is on how it clears the registers + and how it avoids AVX-SSE transition penalties. + AVX2 uses the VPXOR instruction, not available on AVX1. On most Intel + processors, VPXOR is faster is VXORPS. For example, on Sandybridge, VPXOR can + run on any of the 3 ALU execution ports, p0/p1/p5. VXORPS can only run on p5. + Also, AVX1 uses the VZEROUPPER instruction, while AVX2 does not. Newer CPU + doesn't have such a huge transition penaly, and VZEROUPPER is not needed, + moreover, it can make subsequent SSE code slower} + {On ERMSB, see p. 3.7.6 of the + Intel 64 and IA-32 Architectures Optimization Reference Manual} + +{$ifdef EnableMMX} + FastMMCpuFeatureMMX = Byte(UnsignedBit shl 0); +{$endif} + +{$ifdef EnableAVX} + FastMMCpuFeatureAVX1 = Byte(UnsignedBit shl 1); + FastMMCpuFeatureAVX2 = Byte(UnsignedBit shl 2); + {$ifdef EnableAVX512} + FastMMCpuFeatureAVX512 = Byte(UnsignedBit shl 3); + {$endif} +{$endif} + +{$ifdef EnableERMS} + FastMMCpuFeatureERMS = Byte(UnsignedBit shl 4); +{$endif} + +{$ifndef DisablePauseAndSwitchToThread} +{$ifndef AssumePauseAndSwitchToThreadAvailable} + {CPU supports "pause" instruction and Windows supports SwitchToThread() API call} + FastMMCpuFeaturePauseAndSwitch = Byte(UnsignedBit shl 5); +{$endif} +{$endif} + +{$ifdef 32bit_SSE} + {CPU supports xmm registers in 32-bit mode} + FastMMCpuFeatureSSE = Byte(UnsignedBit shl 6); +{$endif} + +{$ifdef EnableFSRM} + {Fast Short REP MOVSB } + FastMMCpuFeatureFSRM = Byte(UnsignedBit shl 7); +{$endif} + +{-------------------------Private variables----------------------------} +var + {-----------------Small block management------------------} +{$ifdef SmallBlocksLockedCriticalSection} + SmallBlockCriticalSections: array[0..NumSmallBlockTypes-1] of TRtlCriticalSection; +{$endif} + + {The small block types. Sizes include the leading header. Sizes are + picked to limit maximum wastage to about 10% or 256 bytes (whichever is + less) where possible.} + SmallBlockTypes: array[0..NumSmallBlockTypes - 1] of TSmallBlockType; + + SmallBlockTypeSizes: array[0..NumSmallBlockTypes - 1] of Word = ( + {8/16 byte jumps} +{$ifndef Align32Bytes} +{$ifndef Align16Bytes} + 8, +{$endif Align16Bytes} + 16, +{$ifndef Align16Bytes} + 24, +{$endif Align16Bytes} +{$endif Align32Bytes} + 32, +{$ifndef Align32Bytes} +{$ifndef Align16Bytes} + 40, +{$endif} + 48, +{$ifndef Align16Bytes} + 56, +{$endif} +{$endif} + 64, +{$ifndef Align32Bytes} +{$ifndef Align16Bytes} + 72, +{$endif} + 80, +{$ifndef Align16Bytes} + 88, +{$endif} +{$endif} + 96, +{$ifndef Align32Bytes} +{$ifndef Align16Bytes} + 104, +{$endif} + 112, +{$ifndef Align16Bytes} + 120, +{$endif} +{$endif} + 128, + +{$ifndef Align32Bytes} +{$ifndef Align16Bytes} + 136, +{$endif} + 144, +{$ifndef Align16Bytes} + 152, +{$endif} +{$endif} + 160, + {16 byte jumps} +{$ifndef Align32Bytes} + 176, +{$endif} + 192, +{$ifndef Align32Bytes} + 208, +{$endif} + 224, +{$ifndef Align32Bytes} + 240, +{$endif} + 256, +{$ifndef Align32Bytes} + 272, +{$endif} + 288, +{$ifndef Align32Bytes} + 304, +{$endif} + 320, + {32 byte jumps} + 352, + 384, + 416, + 448, + 480, +{$ifndef Align32Bytes} + {48 byte jumps if alignment is less than 32 bytes} + 528, + 576, + 624, + 672, + {64 byte jumps} + 736, + 800, + {80 byte jumps if alignment is less than 32 bytes} + 880, + 1024{960}, + {96 byte jumps} + 1056, + 1152, + {112 byte jumps} + 1264, + 1376, + {128 byte jumps} + 1504, + {144 byte jumps} + 1648, + {160 byte jumps} + 1808, + {176 byte jumps} + 2048{1984}, + {192 byte jumps} + 2176, + {208 byte jumps} + 2384, + {224 byte jumps} +{$else} + {keep 32-byte jumps if alignment is 32 bytes} + 512, + 544, + 576, + 608, + 640, + 672, + 704, + 736, + 768, + 800, + 832, + {64 byte jumps} + 896, + 960, + 1024, + 1088, + 1152, + 1216, + 1280, + 1344, + 1408, + {128 byte jumps} + 1536, + 1664, + 1792, + 1920, + 2048, + {256 byte jumps} + 2304, +{$endif} + 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.} + MaximumSmallBlockSize, + MaximumSmallBlockSize); + + + {Size to small block type translation table. + This table helps us to quickly access a corresponding TSmallBlockType entry in the + SmallBlockTypes array.} + +{$ifdef 32Bit} + {$define AllocSize2SmallBlockTypesPrecomputedOffsets} + + {$ifdef ASMVersion} + + {Since the size of TSmallBlockType is 32 bytes in 32-bit mode, + but the maximum scale factor of an index is 8 when calculating an offset on Intel CPUs, + this table contains precomputed offsets from the start of the SmallBlockTypes ararray, + divided by the maximum CPU scale factor, so we don't need to do shl, we just take a value from + this table a and then use *8 scale factor to calculate the effective address and get the value} + + {$DEFINE AllocSize2SmallBlockTypesPrecomputedOffsets} + + {$endif} + + {$ifdef FastGetMemNeedAssemblerCode} + {$DEFINE AllocSize2SmallBlockTypesPrecomputedOffsets} + {$endif} + +{$endif} + + +{$ifdef AllocSize2SmallBlockTypesPrecomputedOffsets} + + AllocSz2SmlBlkTypOfsDivSclFctr: array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte; + +{$else} + + {Since the size of TSmallBlockType is 64 bytes in 64-bit mode and 32 bytes in 32-bit mode, + but the maximum scale factor of an index is 8 when calculating an offset on Intel CPUs, + and the table contains more than 40 elements, one byte in the table is not enough to hold any + offfset value divided by 8, so, for 64-bit mode, we keep here just indexes, and use one additional shl command, + no offsets are precomputed} + AllocSize2SmallBlockTypesIdx: array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte; +{$endif} + + {-----------------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: TSynchronizationVariable; +{$ifdef MediumBlocksLockedCriticalSection} + MediumBlocksLockedCS: TRTLCriticalSection; +{$endif} + + {The sequential feed medium block pool.} + LastSequentiallyFedMediumBlock: Pointer; + MediumSequentialFeedBytesLeft: Cardinal; + {The medium block bins are divided into groups of 32 bins. If a bit + is set in this group bitmap, then at least one bin in the group has free + blocks.} + MediumBlockBinGroupBitmap: Cardinal; + {The medium block bins: total of 32 * 32 = 1024 bins of a certain + minimum size.} + MediumBlockBinBitmaps: array[0..MediumBlockBinGroupCount - 1] of Cardinal; + {The medium block bins. There are 1024 LIFO circular linked lists each + holding blocks of a specified minimum size. The sizes vary in size from + MinimumMediumBlockSize to MaximumMediumBlockSize. The bins are treated as + type TMediumFreeBlock to avoid pointer checks.} + MediumBlockBins: array[0..MediumBlockBinCount - 1] of TMediumFreeBlock; + {-----------------Large block management------------------} + {Are large blocks locked?} + LargeBlocksLocked: TSynchronizationVariable; +{$ifdef LargeBlocksLockedCriticalSection} + LargeBlocksLockedCS: TRTLCriticalSection; +{$endif} + {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: TSynchronizationVariable; +{$endif} + {---------------------EventLog-------------------} +{$ifdef _EventLog} + {The current log file name} + MMLogFileName: array[0..MaxFileNameLength-1] of AnsiChar; +{$endif} + {---------------------Full Debug Mode structures--------------------} +{$ifdef FullDebugMode} + {The allocation group stack} + AllocationGroupStack: array[0..AllocationGroupStackSize - 1] of Cardinal; + {The allocation group stack top (it is an index into AllocationGroupStack)} + AllocationGroupStackTop: Cardinal; + {The last allocation number used} + CurrentAllocationNumber: Cardinal; + {This is a count of the number of threads currently inside any of the + FullDebugMode GetMem, Freemem or ReallocMem handlers. If this value + is negative then a block scan is in progress and no thread may + allocate, free or reallocate any block or modify any FullDebugMode + block header or footer.} + ThreadsInFullDebugModeRoutine: Integer; + {The 64K block of reserved memory used to trap invalid memory accesses using + fields in a freed object.} + ReservedBlock: Pointer; + {Points to a block of size FullDebugModeAddressSpaceSlack that is freed the first time the system runs out of memory. + Memory is never release under FullDebugMode, so this allows the application to continue to function for a short while + after the first EOutOfMemory exception.} + AddressSpaceSlackPtr: Pointer; + {The virtual method index count - used to get the virtual method index for a + virtual method call on a freed object.} + VMIndex: Integer; + {The fake VMT used to catch virtual method calls on freed objects.} + FreedObjectVMT: packed record + VMTData: array[vmtSelfPtr .. vmtParent + SizeOf(Pointer) - 1] of byte; + VMTMethods: array[SizeOf(Pointer) + vmtParent .. vmtParent + MaxFakeVMTEntries * SizeOf(Pointer) + SizeOf(Pointer) - 1] of Byte; + end; + {$ifdef CatchUseOfFreedInterfaces} + VMTBadInterface: array[0..MaxFakeVMTEntries - 1] of Pointer; + {$endif} +{$endif} + + {---------------------Lock contention logging--------------------} +{$ifdef LogLockContention} + MediumBlockCollector: TStaticCollector; + LargeBlockCollector: TStaticCollector; +{$endif} + + {---------------------Release stack------------------------} +{$ifdef UseReleaseStack} + MediumReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack; + LargeReleaseStack: array [0..NumStacksPerBlock - 1] of TLFStack; + ReleaseStackCleanupThread: THandle = 0; + ReleaseStackCleanupThreadTerminate: THandle = 0; +{$endif} + + {--------------Other info--------------} + {The memory manager that was replaced} + OldMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif}; + {The replacement memory manager} + NewMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif}; +{$ifdef DetectMMOperationsAfterUninstall} + {Invalid handlers to catch MM operations after uninstall} + InvalidMemoryManager: {$ifndef BDS2006AndUp}TMemoryManager{$else}TMemoryManagerEx{$endif}; +{$endif} + +{$ifdef MMSharingEnabled} + {A string uniquely identifying the current process (for sharing the memory + manager between DLLs and the main application)} + MappingObjectName: array[0..25] of AnsiChar = ('L', 'o', 'c', 'a', 'l', '\', + 'F', 'a', 's', 't', 'M', 'M', '_', 'P', 'I', 'D', '_', '?', '?', '?', '?', + '?', '?', '?', '?', #0); +{$ifdef EnableBackwardCompatibleMMSharing} + UniqueProcessIDString: array[1..20] of AnsiChar = ('?', '?', '?', '?', '?', + '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', #0); + UniqueProcessIDStringBE: array[1..23] of AnsiChar = ('?', '?', '?', '?', '?', + '?', '?', '?', '_', 'P', 'I', 'D', '_', 'F', 'a', 's', 't', 'M', 'M', '_', + 'B', 'E', #0); + {The handle of the MM window} + MMWindow: HWND; + {The handle of the MM window (for default MM of Delphi 2006 compatibility)} + MMWindowBE: HWND; +{$endif} + {The handle of the memory mapped file} + MappingObjectHandle: NativeUInt; +{$endif} + {Has FastMM been installed?} + FastMMIsInstalled: Boolean; + {Is the MM in place a shared memory manager?} + IsMemoryManagerOwner: Boolean; + +{$ifdef USE_CPUID} + {See FastMMCpuFeature... constants. + We have packe the most interesting CPUID bits in one byte for faster comparison + These features are mostly used for faster memory move operations} + FastMMCpuFeatures: Byte; +{$endif} + + {Is a MessageBox currently showing? If so, do not show another one.} + ShowingMessageBox: Boolean; + {True if RunInitializationCode has been called already.} + InitializationCodeHasRun: Boolean; + +{----------------Utility Functions------------------} + +{A copy of StrLen in order to avoid the SysUtils unit, which would have + introduced overhead like exception handling code.} +function StrLen(const AStr: PAnsiChar): NativeUInt; +{$ifndef Use32BitAsm} +begin + Result := 0; + while AStr[Result] <> #0 do + begin + Inc(Result); + end; +end; +{$else} + assembler; +asm + {Check the first byte} + cmp byte ptr [eax], 0 + je @ZeroLength + {Get the negative of the string start in edx} + mov edx, eax + neg edx + {Word align} + add eax, 1 + and eax, -2 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@ScanLoop: + mov cx, [eax] + add eax, 2 + test cl, ch + jnz @ScanLoop + test cl, cl + jz @ReturnLess2 + test ch, ch + jnz @ScanLoop + lea eax, [eax + edx - 1] + jmp @Finish + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@ReturnLess2: + lea eax, [eax + edx - 2] + jmp @Finish + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@ZeroLength: + xor eax, eax +@Finish: +end; +{$endif} + +{$ifdef USE_CPUID} +{Returns true if the CPUID instruction is supported} +function CPUID_Supported: Boolean; +{$ifdef 32bit} assembler; + +{QUOTE from the Intel 64 and IA-32 Architectures Software Developer's Manual + +22.16.1 Using EFLAGS Flags to Distinguish Between 32-Bit IA-32 Processors +The following bits in the EFLAGS register that can be used to differentiate between the 32-bit IA-32 processors: +- Bit 21 (the ID flag) indicates whether an application can execute the CPUID instruction. The ability to set and +clear this bit indicates that the processor is a P6 family or Pentium processor. The CPUID instruction can then +be used to determine which processor. + +ENDQUOTE} + + +asm + pushfd + pop eax + mov edx, eax +{Test the bit 21 (the ID flag} + xor eax, $200000 + push eax + popfd + pushfd + pop eax + xor eax, edx + setnz al +end; +{$else 32bit} + +{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif} +// CPUID is always supported on 64-bit platforms +begin + Result := True; +end; +{$endif 32bit} + +{Gets the CPUID} +procedure GetCPUID(AEax, AEcx: Cardinal; var R: TCpuIdRegisters); assembler; +{$ifdef 32bit} +asm + push ebx + push esi + +{ According to the 32-bit calling convention, the arguments are passed in the + following registers: + 1) eax (first argument, in the GetCPUID function called "AEax" (Cardinal)) + 2) edx (second argument in the GetCPUID function called "ECx" (Cardinal)) + 3) ecx (third argument, the address of the "R" (TCpuIdRegisters) structure)} + + mov esi, ecx // now the address of the TCpuIdRegisters structure is in esi register + mov ecx, edx // now the value of the second argument is in the ecx register + {Clear the registers, not really needed, justs for sure/safe} + xor ebx, ebx + xor edx, edx + {cpuid instruction} +{$ifdef Delphi4or5} + db $0f, $a2 +{$else} + cpuid +{$endif} + {Save registers} + mov TCpuIdRegisters[esi].RegEAX, eax + mov TCpuIdRegisters[esi].RegEBX, ebx + mov TCpuIdRegisters[esi].RegECX, ecx + mov TCpuIdRegisters[esi].RegEDX, edx + pop esi + pop ebx +end; +{$else 32bit} +asm +{$ifdef AllowAsmNoframe} + .noframe +{$endif} + mov r9, rbx // preserve rbx + + +{ According to the 64-bit calling conventions, the arguments are passed in the + following registers: + + N Windows Unix Comment + 1 rcx rdi first argument, in the GetCPUID function called "AEax" (Cardinal) + 2 rdx rsi second argument in the GetCPUID function called "ECx" (Cardinal) + 3 r8 rdx third argument, the address of the "R" (TCpuIdRegisters) structure + +For Windows, we use Microsoft's Win64 "x64 ABI" calling convention. +For Unix (Linux), we use "System V AMD64 ABI" calling convention. } + + +// load first argument into eax + +{$ifdef unix} + mov eax, edi +{$else} + mov eax, ecx +{$endif} + +// load second argument into ecx + +{$ifdef unix} + mov ecx, esi +{$else} + mov ecx, edx +{$endif} + +// load third argument into r10 + +{$ifdef unix} + mov r10, rdx +{$else} + mov r10, r8 +{$endif} + + + {Clear the register justs for sure, 32-bit operands in 64-bit mode also clear + bits 63-32; moreover, CPUID only operates with 32-bit parts of the registers + even in the 64-bit mode} + + xor ebx, ebx + xor edx, edx + cpuid + {Save registers} + mov TCpuIdRegisters[r10].RegEAX, eax + mov TCpuIdRegisters[r10].RegEBX, ebx + mov TCpuIdRegisters[r10].RegECX, ecx + mov TCpuIdRegisters[r10].RegEDX, edx + mov rbx, r9 +end; +{$endif 32bit} + +{$endif USE_CPUID} + +const +// values for the synchronization variables + cLockByteAvailable = 107; + cLockByteLocked = 109; + cLockByteFinished = 113; + +// the spin-wait loop count for the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cSpinWaitLoopCount = 5000; + +{$ifndef PurePascal} +{$define UseNormalLoadBeforeAcquireLock} +{$endif} + +{$ifdef SimplifiedInterlockedExchangeByte} + +{$ifdef UseNormalLoadBeforeAcquireLock} +function AcquireLockTryNormalLoadFirst(var Target: TSynchronizationVariable): TSynchronizationVariable; assembler; +asm +{$ifdef 32bit} + {On entry: + eax = Target address} + mov ecx, eax + movzx eax, byte ptr [ecx] + cmp eax, cLockByteAvailable + jne @Exit + mov eax, cLockByteLocked + lock xchg [ecx], al +{$else} + {$ifndef unix} + {On entry: + rcx = Target address} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movzx eax, byte ptr [rcx] + cmp eax, cLockByteAvailable + jne @Exit + mov eax, cLockByteLocked + lock xchg [rcx], al + {$else} + {On entry: + rdi = Target address} + movzx eax, byte ptr [rdi] + cmp eax, cLockByteAvailable + jne @Exit + mov eax, cLockByteLocked + lock xchg [rdi], al + {$endif} +{$endif} +@Exit: +end; +{$else} +function InterlockedExchangeByte(var Target: TSynchronizationVariable; const Value: TSynchronizationVariable): TSynchronizationVariable; +{$ifndef ASMVersion} +begin + Result := + {$ifdef SynchroVarLongint} + InterlockedExchange + {$else} + Windows.InterlockedExchange8 + {$endif} + (Target, Value); +end; +{$else ASMVersion} +assembler; +asm +{$ifdef 32bit} + {On entry: + eax = Target address, + dl = NewVal} + mov ecx, eax + movzx eax, dl + lock xchg [ecx], al +{$else 32bit} + {$ifndef unix} + {On entry: + rcx = Target address + dl = NewVal} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movzx eax, dl + lock xchg [rcx], al + {$else} + {On entry: + rdi = Target address + sil = NewVal} + movzx rax, sil + lock xchg [rdi], al + {$endif} +{$endif} +end; +{$endif 32bit} +{$endif ASMVersion} + +{$else !SimplifiedInterlockedExchangeByte} + +{ The "InterlockedCompareExchangeByte" function is not compiled by default in +the FastMM4-AVX brach. The implementation below is the old functionality +of FastMM4 version 4.992. } + +{Compare [AAddress], CompareVal: + If Equal: [AAddress] := NewVal and result = CompareVal + If Unequal: Result := [AAddress]} +function InterlockedCompareExchangeByte(const CompareVal, NewVal: TSynchronizationVariable; var Target: TSynchronizationVariable): TSynchronizationVariable; assembler; {$ifdef fpc64bit}nostackframe;{$endif} +asm +{$ifdef 32Bit} + {On entry: + al = CompareVal, + dl = NewVal, + ecx = AAddress} + {$ifndef unix} + +{Remove false dependency on remainig bits of the eax (31-8), as eax may come +with these bits trashed, and, as a result, the function will also return these +bits trashed in EAX. So, it may produce faster code by removing dependency +and safer code by cleaning possbile trash} + movzx eax, al + movzx edx, dl + +{Compare AL with byte ptr [ecx]. If equal, ZF is set and DL is +loaded into byte ptr [ecx]. Else, clear ZF and load byte ptr [ecx] into AL.} + lock cmpxchg byte ptr [ecx], dl // cmpxchg also uses AL as an implicit operand + +{Clear the registers for safety} + xor ecx, ecx + xor edx, edx + {$else unix} + {Workaround for Kylix compiler bug} + db $F0, $0F, $B0, $11 + {$endif unix} +{$else 32Bit} + +{Microsoft's Win64 "x64 ABI" calling convention.} + + {On entry: + cl = CompareVal + dl = NewVal + r8 = AAddress} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movzx rax, cl {Remove false dependency on remainig bits of the rax} + xor rcx, rcx + lock cmpxchg byte ptr [r8], dl // cmpxchg also uses AL as an implicit operand + xor rdx, rdx + xor r8, r8 + + {$else unix} + +{"System V AMD64 ABI" calling convention - the de facto standard among Unix-like +operating systems. The first four integer or pointer arguments are passed in +registers RDI, RSI, RDX, RCX; return value is stored in RAX and RDX.} + + {On entry: + dil = CompareVal + sil = NewVal + rdx = AAddress} + + movzx rax, dil + lock cmpxchg byte ptr [rdx], sil // cmpxchg also uses AL as an implicit operand + xor rsi, rsi + xor rdi, rdi + xor rdx, rdx + {$endif unix} +{$endif 32Bit} +end; + +{$endif SimplifiedInterlockedExchangeByte} + +{$ifdef FullDebugMode} +{$define DebugAcquireLockByte} +{$define DebugReleaseLockByte} +{$endif} + +{$ifdef DEBUG} +{$define DebugAcquireLockByte} +{$define DebugReleaseLockByte} +{$endif} + + +{$ifndef DisablePauseAndSwitchToThread} +{$ifdef KYLIX} +procedure SwitchToThreadIfSupported; +begin + sched_yield; +end; +{$else} +{$ifdef POSIX} +procedure SwitchToThreadIfSupported; +begin + ThreadSwitch; +end; +{$else} +type + TSwitchToThread = function: BOOL; stdcall; +var + FSwitchToThread: TSwitchToThread; + +procedure SwitchToThreadIfSupported; +begin + if Assigned(FSwitchToThread) then + begin + FSwitchToThread; + end; +end; +{$endif} +{$endif} +{$endif DisablePauseAndSwitchToThread} + +{$ifndef DisablePauseAndSwitchToThread} +{$ifdef AuxAsmRoutines} +procedure AcquireSpinLockMediumBlocks; assembler; +asm +{$ifdef 64bit} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Init: + mov r9d, cSpinWaitLoopCount + mov eax, cLockByteLocked + jmp @FirstCompare + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec r9 + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause +@FirstCompare: +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp [MediumBlocksLocked], al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + lock xchg [MediumBlocksLocked], al + cmp al, cLockByteLocked + je @DidntLock + jmp @Finish +@SwitchToThread: + push rcx + push rdx + push r8 + call SwitchToThreadIfSupported + pop r8 + pop rdx + pop rcx + jmp @Init +@Finish: +{$else} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Init: + mov edx, cSpinWaitLoopCount + mov eax, cLockByteLocked + jmp @FirstCompare + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread + db $F3, $90 // pause +@FirstCompare: + cmp [MediumBlocksLocked], al + je @NormalLoadLoop + lock xchg [MediumBlocksLocked], al + cmp al, cLockByteLocked + je @DidntLock + jmp @Finish +@SwitchToThread: + call SwitchToThreadIfSupported + jmp @Init +@Finish: +{$endif} +end; + + +procedure AcquireSpinLockByte(var Target: TSynchronizationVariable); assembler; +asm +{$ifdef 64bit} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {$ifdef unix} + mov rcx, rdi + {$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Init: + mov r9d, cSpinWaitLoopCount + mov eax, cLockByteLocked + jmp @FirstCompare + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec r9 + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause +@FirstCompare: +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp [rcx], al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + lock xchg [rcx], al + cmp al, cLockByteLocked + je @DidntLock + jmp @Finish +@SwitchToThread: + push rcx + call SwitchToThreadIfSupported + pop rcx + jmp @Init +@Finish: +{$else} + mov ecx, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Init: + mov edx, cSpinWaitLoopCount + mov eax, cLockByteLocked + jmp @FirstCompare + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread + db $F3, $90 // pause +@FirstCompare: + cmp [ecx], al + je @NormalLoadLoop + lock xchg [ecx], al + cmp al, cLockByteLocked + je @DidntLock + jmp @Finish +@SwitchToThread: + push ecx + call SwitchToThreadIfSupported + pop ecx + jmp @Init +@Finish: +{$endif} +end; +{$endif ASMVersion} +{$endif DisablePauseAndSwitchToThread} + + +function AcquireLockByte(var Target: TSynchronizationVariable): Boolean; + {$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} +var + R: Byte; +begin + {$ifdef SimplifiedInterlockedExchangeByte} + R := + {$ifdef UseNormalLoadBeforeAcquireLock} + AcquireLockTryNormalLoadFirst(Target); + {$else} + InterlockedExchangeByte(Target, cLockByteLocked); + {$endif} + {$else} + R := InterlockedCompareExchangeByte(cLockByteAvailable, cLockByteLocked, Target); + {$endif} + {$ifdef DebugAcquireLockByte} + case R of + cLockByteAvailable: Result := True; + cLockByteLocked: Result := False; + else + begin + Result := False; + {$ifndef SystemRunError} + System.Error(reInvalidOp); + {$else} + System.RunError(reInvalidOp); + {$endif} + end; + end; + {$else} + Result := R = CLockByteAvailable; + {$endif} +end; + + +{ Look for "using normal memory store" in the comment section +at the beginning of the file for the discussion on releasing locks on data +structures. You can also define the "InterlockedRelease" option in the +FastMM4Options.inc file to get the old behaviour of the origina FastMM4. } + +procedure ReleaseLockByte(var Target: TSynchronizationVariable); + + {$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} + +{$ifdef DebugReleaseLockByte} +var + R: Byte; +{$endif} +begin + {$ifdef InterlockedRelease} + {$ifdef SimplifiedInterlockedExchangeByte} + {$ifdef DebugReleaseLockByte} + R := + {$endif} + InterlockedExchangeByte(Target, cLockByteAvailable); + {$else} + {$ifdef DebugReleaseLockByte} + R := + {$endif} + InterlockedCompareExchangeByte(cLockByteLocked, cLockByteAvailable, Target); + {$endif} + {$else} + {$ifdef DebugReleaseLockByte} + R := Target; + {$endif} + Target := CLockByteAvailable; + {$endif} + {$ifdef DebugReleaseLockByte} + if R <> cLockByteLocked then + begin + {$ifndef SystemRunError} + System.Error(reInvalidOp); + {$else} + System.RunError(reInvalidOp); + {$endif} + end; + {$endif} +end; + + + +{$ifdef MACOS_OR_KYLIX} + +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +var + Len: Cardinal; +begin + Result := Dest; + Len := StrLen(Source); + if Len > MaxLen then + Len := MaxLen; + Move(Source^, Dest^, Len * SizeOf(AnsiChar)); + Dest[Len] := #0; +end; + +function GetModuleFileName(Module: HMODULE; Buffer: PAnsiChar; BufLen: Integer): Integer; +const + CUnknown = 'unknown'#0; +var + LUnknown: array[0..Length(CUnknown)-1] of AnsiChar = CUnknown; +begin + if FastMMIsInstalled then + begin + Result := System.GetModuleFileName(Module, tmp, BufLen); + StrLCopy(Buffer, PAnsiChar(AnsiString(tmp)), BufLen); + end + else + begin + Result := Length(CUnknown); + StrLCopy(Buffer, PAnsiChar(CUnknown), Result + 1); + end; +end; + +const + INVALID_HANDLE_VALUE = THandle(-1); + +function FileCreate(const FileName: string): THandle; +begin + Result := THandle({$ifdef MACOS}__open{$else}open{$endif}( + PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAccessRights)); +end; + +{$endif} + +{$ifdef FPC} +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +var + Len: Cardinal; +begin + Result := Dest; + Len := StrLen(Source); + if Len > MaxLen then + Len := MaxLen; + Move(Source^, Dest^, Len * SizeOf(AnsiChar)); + Dest[Len] := #0; +end; + +function GetModuleFileName(Module: HMODULE; Buffer: PAnsiChar; BufLen: Integer): Integer; +const + CUnknown = 'unknown'#0; +var + LUnknown: array[0..Length(CUnknown)-1] of AnsiChar = CUnknown; +begin + Result := Length(CUnknown); + if Result > BufLen then Result := BufLen; + StrLCopy(Buffer, @LUnknown, Result); +end; + +{$ifdef POSIX} +const + INVALID_HANDLE_VALUE = THandle(-1); + FileAcc = (S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH); + +function FileCreate(const FileName: string): THandle; +begin + Result := THandle(fpopen(PAnsiChar(UTF8String(FileName)), O_RDWR or O_CREAT or O_TRUNC or O_EXCL, FileAcc)); +end; +{$endif} + +{$endif} + +{Writes the module filename to the specified buffer and returns the number of + characters written.} +function AppendModuleFileName(ABuffer: PAnsiChar; ABufferLengthChars: Integer {including the terminating null character}): Integer; +var + LModuleHandle: HModule; +begin + {Get the module handle} +{$ifndef borlndmmdll} + if IsLibrary then + LModuleHandle := HInstance + else +{$endif} + LModuleHandle := 0; + {Get the module name} +{$ifndef POSIX} + Result := GetModuleFileNameA(LModuleHandle, ABuffer, ABufferLengthChars); +{$else} + Result := GetModuleFileName(LModuleHandle, ABuffer, ABufferLengthChars); +{$endif} +end; + +{Copies the name of the module followed by the given string to the buffer, + returning the pointer following the buffer.} +function AppendStringToModuleName(AString, ABuffer: PAnsiChar; AStringLength, ABufferLength: Cardinal): PAnsiChar; +const + CNumReservedCharsInModuleName = 5; {reserve some extra characters for colon and space} +var + LModuleNameLength: Cardinal; + LCopyStart: PAnsiChar; + LStringLength, LBufferLength: Cardinal; + LString, LBuffer: PAnsiChar; +begin + LString := AString; + LStringLength := AStringLength; + LBuffer := ABuffer; + LBufferLength := ABufferLength; + {Get the name of the application} + LModuleNameLength := AppendModuleFileName(LBuffer, LBufferLength); + {Replace the last few characters} + if (LModuleNameLength > 0) and (LModuleNameLength + CNumReservedCharsInModuleName < LBufferLength) then + begin + {Find the last backslash} + LCopyStart := PAnsiChar(PByte(LBuffer) + LModuleNameLength - 1); + LModuleNameLength := 0; + while (UIntPtr(LCopyStart) >= UIntPtr(LBuffer)) + and (LCopyStart^ <> '\') do + begin + Inc(LModuleNameLength); + Dec(LCopyStart); + end; + {Copy the name to the start of the buffer} + Inc(LCopyStart); + System.Move(LCopyStart^, LBuffer^, LModuleNameLength*SizeOf(LCopyStart[0])); + Inc(LBuffer, LModuleNameLength); + if LBufferLength >= LModuleNameLength then + begin + Dec(LBufferLength, LModuleNameLength); + if LBufferLength > 0 then + begin + LBuffer^ := ':'; + Inc(LBuffer); + Dec(LBufferLength); + if LBufferLength > 0 then + begin + LBuffer^ := ' '; + Inc(LBuffer); + Dec(LBufferLength); + end; + end; + end; + end; + {Append the string} + while (LString^ <> #0) and (LBufferLength > 0) and (LStringLength > 0) do + begin + LBuffer^ := LString^; + Dec(LBufferLength); + Inc(LBuffer); + {Next char} + Inc(LString); + Dec(LStringLength); + end; + LBuffer^ := #0; + Result := LBuffer; +end; + +{----------------------------Faster Move Procedures----------------------------} + +{Fixed size move operations ignore the size parameter. All moves are assumed to + be non-overlapping.} + +{$ifdef UseCustomFixedSizeMoveRoutines} + +{$ifdef 64bit} + +procedure Move24Reg64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + mov rax, [rcx + 0*8] + mov r8, [rcx + 1*8] + mov r9, [rcx + 2*8] + mov [rdx + 0*8], rax + mov [rdx + 1*8], r8 + mov [rdx + 2*8], r9 + {$else} + mov rax, [rdi + 0*8] + mov rdx, [rdi + 1*8] + mov rcx, [rdi + 2*8] + mov [rsi + 0*8], rax + mov [rsi + 1*8], rdx + mov [rsi + 2*8], rcx + {$endif} +end; + +procedure Move32Reg64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + mov rax, [rcx + 0*8] + mov r8, [rcx + 1*8] + mov r9, [rcx + 2*8] + mov r10, [rcx + 3*8] + mov [rdx + 0*8], rax + mov [rdx + 1*8], r8 + mov [rdx + 2*8], r9 + mov [rdx + 3*8], r10 + {$else} + mov rax, [rdi + 0*8] + mov rdx, [rdi + 1*8] + mov rcx, [rdi + 2*8] + mov r8, [rdi + 3*8] + mov [rsi + 0*8], rax + mov [rsi + 1*8], rdx + mov [rsi + 2*8], rcx + mov [rsi + 3*8], r8 + {$endif} +end; + + +procedure Move40Reg64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + mov rax, [rcx + 0*8] + mov r8, [rcx + 1*8] + mov r9, [rcx + 2*8] + mov r10, [rcx + 3*8] + mov r11, [rcx + 4*8] + mov [rdx + 0*8], rax + mov [rdx + 1*8], r8 + mov [rdx + 2*8], r9 + mov [rdx + 3*8], r10 + mov [rdx + 4*8], r11 + {$else} + mov rax, [rdi + 0*8] + mov rdx, [rdi + 1*8] + mov rcx, [rdi + 2*8] + mov r8, [rdi + 3*8] + mov r9, [rdi + 4*8] + mov [rsi + 0*8], rax + mov [rsi + 1*8], rdx + mov [rsi + 2*8], rcx + mov [rsi + 3*8], r8 + mov [rsi + 4*8], r9 + {$endif} +end; + + +procedure Move48Reg64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + mov rax, [rcx + 0*8] + mov r8, [rcx + 1*8] + mov r9, [rcx + 2*8] + mov r10, [rcx + 3*8] + mov [rdx + 0*8], rax + mov [rdx + 1*8], r8 + mov [rdx + 2*8], r9 + mov [rdx + 3*8], r10 + mov rax, [rcx + 4*8] + mov r8, [rcx + 5*8] + mov [rdx + 4*8], rax + mov [rdx + 5*8], r8 + {$else} + mov rax, [rdi + 0*8] + mov rdx, [rdi + 1*8] + mov rcx, [rdi + 2*8] + mov r8, [rdi + 3*8] + mov [rsi + 0*8], rax + mov [rsi + 1*8], rdx + mov [rsi + 2*8], rcx + mov [rsi + 3*8], r8 + mov rax, [rdi + 4*8] + mov rdx, [rdi + 5*8] + mov [rsi + 4*8], rax + mov [rsi + 5*8], rdx + {$endif} +end; + + +procedure Move56Reg64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + mov rax, [rcx + 0*8] + mov r8, [rcx + 1*8] + mov r9, [rcx + 2*8] + mov r10, [rcx + 3*8] + mov [rdx + 0*8], rax + mov [rdx + 1*8], r8 + mov [rdx + 2*8], r9 + mov [rdx + 3*8], r10 + mov rax, [rcx + 4*8] + mov r8, [rcx + 5*8] + mov r9, [rcx + 6*8] + mov [rdx + 4*8], rax + mov [rdx + 5*8], r8 + mov [rdx + 6*8], r9 + {$else} + mov rax, [rdi + 0*8] + mov rdx, [rdi + 1*8] + mov rcx, [rdi + 2*8] + mov r8, [rdi + 3*8] + mov [rsi + 0*8], rax + mov [rsi + 1*8], rdx + mov [rsi + 2*8], rcx + mov [rsi + 3*8], r8 + mov rax, [rdi + 4*8] + mov rdx, [rdi + 5*8] + mov rcx, [rdi + 6*8] + mov [rsi + 4*8], rax + mov [rsi + 5*8], rdx + mov [rsi + 6*8], rcx + {$endif} +end; + +{$endif} + +{$ifdef EnableAVX} + + + + +{$ifndef DisableAVX1} + +{----------------------------AVX1 Move Procedures----------------------------} + +procedure Move24AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + db $C5, $F9, $6F, $01 // vmovdqa xmm0, xmmword ptr[rcx] + mov r8, [rcx + 16] + db $C5, $F9, $7F, $02 // vmovdqa xmmword ptr[rdx], xmm0 + mov [rdx + 16], r8 + {$else} + db $C5, $F9, $6F, $07 // vmovdqa xmm0, xmmword ptr[rdi] + mov rdx, [rdi + 16] + db $C5, $F9, $7F, $06 // vmovdqa xmmword ptr[rsi], xmm0 + mov [rsi + 16], rdx + {$endif} + db $C5, $F8, $57, $C0 // vxorps xmm0,xmm0,xmm0 + db $C5, $F8, $77 // vzeroupper +end; + + +procedure Move56AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $F9, $6F, $49, $20 // vmovdqa xmm1, xmmword ptr [rcx+20h] + mov r8, [rcx + 48] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $F9, $7F, $4A, $20 // vmovdqa xmmword ptr [rdx+20h], xmm1 + mov [rdx + 48], r8 + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $F9, $6F, $4F, $20 // vmovdqa xmm1, xmmword ptr [rdi+20h] + mov rdx, [rdi + 48] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $F9, $7F, $4E, $20 // vmovdqa xmmword ptr [rsi+20h], xmm1 + mov [rsi + 48], rdx + {$endif} + db $C5, $FC, $57, $C0 // vxorps ymm0, ymm0, ymm0 + db $C5, $F0, $57, $C9 // vxorps xmm1, xmm1, xmm1 + db $C5, $F8, $77 // vzeroupper +end; + +procedure Move88AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $FD, $6F, $49, $20 // vmovdqa ymm1, ymmword ptr [rcx+20h] + db $C5, $F9, $6F, $51, $40 // vmovdqa xmm2, xmmword ptr [rcx+40h] + mov rcx, [rcx + 50h] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $FD, $7F, $4A, $20 // vmovdqa ymmword ptr [rdx+20h], ymm1 + db $C5, $F9, $7F, $52, $40 // vmovdqa xmmword ptr [rdx+40h], xmm2 + mov [rdx + 50h], rcx + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $FD, $6F, $4F, $20 // vmovdqa ymm1, ymmword ptr [rdi+20h] + db $C5, $F9, $6F, $57, $40 // vmovdqa xmm2, xmmword ptr [rdi+40h] + mov rdi, [rdi + 50h] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $FD, $7F, $4E, $20 // vmovdqa ymmword ptr [rsi+20h], ymm1 + db $C5, $F9, $7F, $56, $40 // vmovdqa xmmword ptr [rsi+40h], xmm2 + mov [rsi + 50h], rdi + {$endif} + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $E8, $57, $D2 // vxorps xmm2,xmm2,xmm2 + db $C5, $F8, $77 // vzeroupper +end; + +procedure Move120AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + +{We are using that many ymm registers (not just two of them in a sequence), +because our routines allow overlapped moves (although it is not neede for +FastMM4 realloc). However, there is no speed increase in using more than +two registers, because we have just two load units and just one store unit +on most CPUs} + + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $FD, $6F, $49, $20 // vmovdqa ymm1, ymmword ptr [rcx+20h] + db $C5, $FD, $6F, $51, $40 // vmovdqa ymm2, ymmword ptr [rcx+40h] + db $C5, $F9, $6F, $59, $60 // vmovdqa xmm3, xmmword ptr [rcx+60h] + mov rcx, [rcx + 70h] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $FD, $7F, $4A, $20 // vmovdqa ymmword ptr [rdx+20h], ymm1 + db $C5, $FD, $7F, $52, $40 // vmovdqa ymmword ptr [rdx+40h], ymm2 + db $C5, $F9, $7F, $5A, $60 // vmovdqa xmmword ptr [rdx+60h], xmm3 + mov [rdx + 70h], rcx + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $FD, $6F, $4F, $20 // vmovdqa ymm1, ymmword ptr [rdi+20h] + db $C5, $FD, $6F, $57, $40 // vmovdqa ymm2, ymmword ptr [rdi+40h] + db $C5, $F9, $6F, $5F, $60 // vmovdqa xmm3, xmmword ptr [rdi+60h] + mov rdi, [rdi + 70h] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $FD, $7F, $4E, $20 // vmovdqa ymmword ptr [rsi+20h], ymm1 + db $C5, $FD, $7F, $56, $40 // vmovdqa ymmword ptr [rsi+40h], ymm2 + db $C5, $F9, $7F, $5E, $60 // vmovdqa ymmword ptr [rsi+60h], xmm3 + mov [rsi + 70h], rdi + {$endif} + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E0, $57, $DB // vxorps xmm3,xmm3,xmm3 + db $C5, $F8, $77 // vzeroupper +end; + +procedure Move152AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + +{We add to the source and destination registers to allow all future offsets +be in range -127..+127 to have 1-byte offset encoded in the opcodes, not 4 +bytes, so the opcode will be shorter by 4 bytes, the overall code will be +shorter, and, as a result, faster, inspite of the sacrifice that we make +at the start of the routine. The sacrifice is small - maybe just 1 cycle, or +less, by "add rcx", but it pays up later} + + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $F9, $6F, $61, $20 // vmovdqa xmm4, [rcx+20h] + mov rcx, [rcx+30h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $F9, $7F, $62, $20 // vmovdqa [rdx+20h], xmm4 + mov [rdx+30h],rcx + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $F9, $6F, $67, $20 // vmovdqa xmm4, [rdi+20h] + mov rdi, [rdi+30h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $F9, $7F, $66, $20 // vmovdqa [rsi+20h], xmm4 + mov [rsi+30h], rdi + {$endif} +{See the comment at Move120AVX1 on why we are using that many ymm registers} + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E4, $57, $DB // vxorps ymm3,ymm3,ymm3 + db $C5, $D8, $57, $E4 // vxorps xmm4,xmm4,xmm4 + db $C5, $F8, $77 // vzeroupper +end; + +procedure Move184AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + +{We add to the source and destination registers to allow all future offsets +be in range -127..+127, see explanation at the Move152AVX1 routine} + + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $FD, $6F, $61, $20 // vmovdqa ymm4, [rcx+20h] + db $C5, $F9, $6F, $69, $40 // vmovdqa xmm5, [rcx+40h] + mov rcx, [rcx+50h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $FD, $7F, $62, $20 // vmovdqa [rdx+20h], ymm4 + db $C5, $F9, $7F, $6A, $40 // vmovdqa [rdx+40h], xmm5 + mov [rdx+50h], rcx + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $FD, $6F, $67, $20 // vmovdqa ymm4, [rdi+20h] + db $C5, $F9, $6F, $6F, $40 // vmovdqa xmm5, [rdi+40h] + mov rdi, [rdi+50h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $FD, $7F, $66, $20 // vmovdqa [rsi+20h], ymm4 + db $C5, $F9, $7F, $6E, $40 // vmovdqa [rsi+40h], xmm5 + mov [rsi+50h], rdi + {$endif} + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E4, $57, $DB // vxorps ymm3,ymm3,ymm3 + db $C5, $DC, $57, $E4 // vxorps ymm4,ymm4,ymm4 + db $C5, $D0, $57, $ED // vxorps xmm5,xmm5,xmm5 + db $C5, $F8, $77 // vzeroupper +end; + +procedure Move216AVX1(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + + db $C5, $F8, $77 // vzeroupper + + {$ifndef unix} + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $FD, $6F, $61, $20 // vmovdqa ymm4, [rcx+20h] + db $C5, $FD, $6F, $69, $40 // vmovdqa ymm5, [rcx+40h] + +{The xmm6/ymm6 register is nonvolatile, according to +Microsoft's x64 calling convention, used for Win64, +denoted "The x64 Application Binary Interface (ABI)", or, briefly, "x64 ABI". +Since we cannot use xmm6, we use general-purpose +64-bit registers to copy remaining data. + +According to Microsoft, "The x64 ABI considers registers RBX, RBP, RDI, RSI, RSP, R12, R13, R14, R15, and XMM6-XMM15 nonvolatile. They must be saved and restored by a function that uses them" + +We are using that many ymm registers, not just two of them in a sequence, +because our routines allow overlapped moves (although it is not needed for +FastMM4 realloc) - see the comment at Move120AVX1 on why we are using that +many ymm registers.} + + + mov r9, [rcx+60h] + mov r10, [rcx+68h] + mov r11, [rcx+70h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $FD, $7F, $62, $20 // vmovdqa [rdx+20h], ymm4 + db $C5, $FD, $7F, $6A, $40 // vmovdqa [rdx+40h], ymm5 + mov [rdx+60h], r9 + mov [rdx+68h], r10 + mov [rdx+70h], r11 + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $FD, $6F, $67, $20 // vmovdqa ymm4, [rdi+20h] + db $C5, $FD, $6F, $6F, $40 // vmovdqa ymm5, [rdi+40h] + +{Although, under unix, we can use xmm6(ymm6) and xmm7 (ymm7), here we mimic +the Win64 code, thus use up to ymm5, and use general-purpose 64-bit registers +to copy remaining data - 24 bytes, which is still smaller than the full ymm +register (32 bytes)} + mov r9, [rdi+60h] + mov r10, [rdi+68h] + mov r11, [rdi+70h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $FD, $7F, $66, $20 // vmovdqa [rsi+20h], ymm4 + db $C5, $FD, $7F, $6E, $40 // vmovdqa [rsi+40h], ymm5 + mov [rsi+60h], r9 + mov [rsi+68h], r10 + mov [rsi+70h], r11 + {$endif} + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E4, $57, $DB // vxorps ymm3,ymm3,ymm3 + db $C5, $DC, $57, $E4 // vxorps ymm4,ymm4,ymm4 + db $C5, $D4, $57, $ED // vxorps ymm5,ymm5,ymm5 + db $C5, $F8, $77 // vzeroupper +end; +{$endif DisableAVX1} + + +{$ifndef DisableAVX2} + +{----------------------------AVX2 Move Procedures----------------------------} + +procedure Move24AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + db $C5, $F9, $6F, $01 // vmovdqa xmm0, xmmword ptr[rcx] + mov r8, [rcx + 16] + db $C5, $F9, $7F, $02 // vmovdqa xmmword ptr[rdx], xmm0 + mov [rdx + 16], r8 + {$else} + db $C5, $F9, $6F, $07 // vmovdqa xmm0, xmmword ptr[rdi] + mov rdx, [rdi + 16] + db $C5, $F9, $7F, $06 // vmovdqa xmmword ptr[rsi], xmm0 + mov [rsi + 16], rdx + {$endif} + db $C5, $F9, $EF, $C0 // vpxor xmm0,xmm0,xmm0 +end; + +procedure Move56AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $F9, $6F, $49, $20 // vmovdqa xmm1, xmmword ptr [rcx+20h] + mov r8, [rcx + 48] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $F9, $7F, $4A, $20 // vmovdqa xmmword ptr [rdx+20h], xmm1 + mov [rdx + 48], r8 + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $F9, $6F, $4F, $20 // vmovdqa xmm1, xmmword ptr [rdi+20h] + mov rdx, [rdi + 48] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $F9, $7F, $4E, $20 // vmovdqa xmmword ptr [rsi+20h], xmm1 + mov [rsi + 48], rdx + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0, ymm0, ymm0 + db $C5, $F1, $EF, $C9 // vpxor xmm1, xmm1, xmm1 +end; + +procedure Move88AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $FD, $6F, $49, $20 // vmovdqa ymm1, ymmword ptr [rcx+20h] + db $C5, $F9, $6F, $51, $40 // vmovdqa xmm2, xmmword ptr [rcx+40h] + mov rcx, [rcx + 50h] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $FD, $7F, $4A, $20 // vmovdqa ymmword ptr [rdx+20h], ymm1 + db $C5, $F9, $7F, $52, $40 // vmovdqa xmmword ptr [rdx+40h], xmm2 + mov [rdx + 50h], rcx + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $FD, $6F, $4F, $20 // vmovdqa ymm1, ymmword ptr [rdi+20h] + db $C5, $F9, $6F, $57, $40 // vmovdqa xmm2, xmmword ptr [rdi+40h] + mov rdi, [rdi + 50h] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $FD, $7F, $4E, $20 // vmovdqa ymmword ptr [rsi+20h], ymm1 + db $C5, $F9, $7F, $56, $40 // vmovdqa xmmword ptr [rsi+40h], xmm2 + mov [rsi + 50h], rdi + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $E9, $EF, $D2 // vpxor xmm2,xmm2,xmm2 +end; + +procedure Move120AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + db $C5, $FD, $6F, $01 // vmovdqa ymm0, ymmword ptr [rcx] + db $C5, $FD, $6F, $49, $20 // vmovdqa ymm1, ymmword ptr [rcx+20h] + db $C5, $FD, $6F, $51, $40 // vmovdqa ymm2, ymmword ptr [rcx+40h] + db $C5, $F9, $6F, $59, $60 // vmovdqa xmm3, xmmword ptr [rcx+60h] + mov rcx, [rcx + 70h] + db $C5, $FD, $7F, $02 // vmovdqa ymmword ptr [rdx], ymm0 + db $C5, $FD, $7F, $4A, $20 // vmovdqa ymmword ptr [rdx+20h], ymm1 + db $C5, $FD, $7F, $52, $40 // vmovdqa ymmword ptr [rdx+40h], ymm2 + db $C5, $F9, $7F, $5A, $60 // vmovdqa xmmword ptr [rdx+60h], xmm3 + mov [rdx + 70h], rcx + {$else} + db $C5, $FD, $6F, $07 // vmovdqa ymm0, ymmword ptr [rdi] + db $C5, $FD, $6F, $4F, $20 // vmovdqa ymm1, ymmword ptr [rdi+20h] + db $C5, $FD, $6F, $57, $40 // vmovdqa ymm2, ymmword ptr [rdi+40h] + db $C5, $F9, $6F, $5F, $60 // vmovdqa xmm3, xmmword ptr [rdi+60h] + mov rdi, [rdi + 70h] + db $C5, $FD, $7F, $06 // vmovdqa ymmword ptr [rsi], ymm0 + db $C5, $FD, $7F, $4E, $20 // vmovdqa ymmword ptr [rsi+20h], ymm1 + db $C5, $FD, $7F, $56, $40 // vmovdqa ymmword ptr [rsi+40h], ymm2 + db $C5, $F9, $7F, $5E, $60 // vmovdqa ymmword ptr [rsi+60h], xmm3 + mov [rsi + 70h], rdi + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E1, $EF, $DB // vpxor xmm3,xmm3,xmm3 +end; + +procedure Move152AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $F9, $6F, $61, $20 // vmovdqa xmm4, [rcx+20h] + mov rcx, [rcx+30h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $F9, $7F, $62, $20 // vmovdqa [rdx+20h], xmm4 + mov [rdx+30h], rcx + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $F9, $6F, $67, $20 // vmovdqa xmm4, [rdi+20h] + mov rdi, [rdi+30h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $F9, $7F, $66, $20 // vmovdqa [rsi+20h], xmm4 + mov [rsi+30h], rdi + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E5, $EF, $DB // vpxor ymm3,ymm3,ymm3 + db $C5, $D9, $EF, $E4 // vpxor xmm4,xmm4,xmm4 +end; + +procedure Move184AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $FD, $6F, $61, $20 // vmovdqa ymm4, [rcx+20h] + db $C5, $F9, $6F, $69, $40 // vmovdqa xmm5, [rcx+40h] + mov rcx, [rcx+50h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $FD, $7F, $62, $20 // vmovdqa [rdx+20h], ymm4 + db $C5, $F9, $7F, $6A, $40 // vmovdqa [rdx+40h], xmm5 + mov [rdx+50h],rcx + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $FD, $6F, $67, $20 // vmovdqa ymm4, [rdi+20h] + db $C5, $F9, $6F, $6F, $40 // vmovdqa xmm5, [rdi+40h] + mov rdi, [rdi+50h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $FD, $7F, $66, $20 // vmovdqa [rsi+20h], ymm4 + db $C5, $F9, $7F, $6E, $40 // vmovdqa [rsi+40h], xmm5 + mov [rsi+50h], rdi + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E5, $EF, $DB // vpxor ymm3,ymm3,ymm3 + db $C5, $DD, $EF, $E4 // vpxor ymm4,ymm4,ymm4 + db $C5, $D1, $EF, $ED // vpxor xmm5,xmm5,xmm5 +end; + +procedure Move216AVX2(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + add rcx, 60h + add rdx, 60h + db $C5, $FD, $6F, $41, $A0 // vmovdqa ymm0, [rcx-60h] + db $C5, $FD, $6F, $49, $C0 // vmovdqa ymm1, [rcx-40h] + db $C5, $FD, $6F, $51, $E0 // vmovdqa ymm2, [rcx-20h] + db $C5, $FD, $6F, $19 // vmovdqa ymm3, [rcx] + db $C5, $FD, $6F, $61, $20 // vmovdqa ymm4, [rcx+20h] + db $C5, $FD, $6F, $69, $40 // vmovdqa ymm5, [rcx+40h] + mov r9, [rcx+60h] + mov r10, [rcx+68h] + mov r11, [rcx+70h] + db $C5, $FD, $7F, $42, $A0 // vmovdqa [rdx-60h], ymm0 + db $C5, $FD, $7F, $4A, $C0 // vmovdqa [rdx-40h], ymm1 + db $C5, $FD, $7F, $52, $E0 // vmovdqa [rdx-20h], ymm2 + db $C5, $FD, $7F, $1A // vmovdqa [rdx], ymm3 + db $C5, $FD, $7F, $62, $20 // vmovdqa [rdx+20h], ymm4 + db $C5, $FD, $7F, $6A, $40 // vmovdqa [rdx+40h], ymm5 + mov [rdx+60h], r9 + mov [rdx+68h], r10 + mov [rdx+70h], r11 + {$else} + add rdi, 60h + add rsi, 60h + db $C5, $FD, $6F, $47, $A0 // vmovdqa ymm0, [rdi-60h] + db $C5, $FD, $6F, $4F, $C0 // vmovdqa ymm1, [rdi-40h] + db $C5, $FD, $6F, $57, $E0 // vmovdqa ymm2, [rdi-20h] + db $C5, $FD, $6F, $1F // vmovdqa ymm3, [rdi] + db $C5, $FD, $6F, $67, $20 // vmovdqa ymm4, [rdi+20h] + db $C5, $FD, $6F, $6F, $40 // vmovdqa ymm5, [rdi+40h] + +{ + +Although, under unix, we can use xmm6(ymm6) and xmm7 (ymm7), here we mimic the Win64 code, see the comment at Move216AVX1 on this. + +We cannot use xmm6(ymm6) and xmm7 (ymm7) under Windows due to the calling convention. + +According to Microsoft, "The registers RBX, RBP, RDI, RSI, RSP, R12, R13, R14, R15, and XMM6-15 are considered nonvolatile and must be saved and restored by a function that uses them." + +} + mov r9, [rdi+60h] + mov r10, [rdi+68h] + mov r11, [rdi+70h] + db $C5, $FD, $7F, $46, $A0 // vmovdqa [rsi-60h], ymm0 + db $C5, $FD, $7F, $4E, $C0 // vmovdqa [rsi-40h], ymm1 + db $C5, $FD, $7F, $56, $E0 // vmovdqa [rsi-20h], ymm2 + db $C5, $FD, $7F, $1E // vmovdqa [rsi], ymm3 + db $C5, $FD, $7F, $66, $20 // vmovdqa [rsi+20h], ymm4 + db $C5, $FD, $7F, $6E, $40 // vmovdqa [rsi+40h], ymm5 + mov [rsi+60h], r9 + mov [rsi+68h], r10 + mov [rsi+70h], r11 + {$endif} + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E5, $EF, $DB // vpxor ymm3,ymm3,ymm3 + db $C5, $DD, $EF, $E4 // vpxor ymm4,ymm4,ymm4 + db $C5, $D5, $EF, $ED // vpxor ymm5,ymm5,ymm5 +end; +{$endif DisableAVX2} + +{$ifdef EnableAVX512} +{$ifdef unix} +AVX-512 is not yet implemented for UNIX +{$else unix} +procedure Move24AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move56AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move88AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move120AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move152AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move184AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move216AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move248AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move280AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move312AVX512(const ASource; var ADest; ACount: NativeInt); external; +procedure Move344AVX512(const ASource; var ADest; ACount: NativeInt); external; +{$ifndef DisableMoveX32LpAvx512} +procedure MoveX32LpAvx512WithErms(const ASource; var ADest; ACount: NativeInt); external; +{$endif} + +{ FastMM4_AVX512.obj file is needed to enable AVX-512 code for FastMM4-AVX. + Use "nasm.exe -Ox -f win64 FastMM4_AVX512.asm" to compile this .obj file. + + Define DisableAVX512 if you don't want to compile this .obj file.} + +{$L FastMM4_AVX512.obj} + + +{$endif unix} +{$endif EnableAVX512} + + +{$endif EnableAVX} +{$endif 64bit} + +{--------------Register, FPU, MMX and SSE Move Procedures--------------} + +{$ifndef ExcludeSmallGranularMoves} + +procedure Move4(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + mov eax, [eax] + mov [edx], eax +{$else 32Bit} + {$ifndef unix} +.noframe + mov eax, [rcx] + mov [rdx], eax + {$else unix} + mov eax, [rdi] + mov [rsi], eax + {$endif unix} +{$endif 32bit} +end; + +{$ifdef 64Bit} +procedure Move8(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifndef unix} +.noframe + mov rax, [rcx] + mov [rdx], rax +{$else} + mov rax, [rdi] + mov [rsi], rax +{$endif} +end; + +procedure Move16(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifndef unix} +.noframe + mov rax, [rcx] + mov rcx, [rcx+8] + mov [rdx], rax + mov [rdx+8], rcx +{$else} + mov rax, [rdi] + mov rdi, [rdi+8] + mov [rsi], rax + mov [rsi+8], rdi +{$endif} +end; + + +procedure Move32(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} + .noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx+16] + movdqa [rdx], xmm0 + movdqa [rdx+16], xmm1 + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi+16] + movdqa [rsi], xmm0 + movdqa [rsi+16], xmm1 + {$endif} +{$else} + {$ifndef unix} + .noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx+16] + movdqu [rdx], xmm0 + movdqu [rdx+16], xmm1 + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi+16] + movdqu [rsi], xmm0 + movdqu [rsi+16], xmm1 + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +end; + +{$endif 64bit} + +procedure Move12(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov eax, [eax + 8] + mov [edx + 4], ecx + mov [edx + 8], eax +{$else} + {$ifndef unix} +.noframe + mov rax, [rcx] + mov ecx, [rcx + 8] + mov [rdx], rax + mov [rdx + 8], ecx + {$else} + mov rax, [rdi] + mov edi, [rdi + 8] + mov [rsi], rax + mov [rsi + 8], edi + {$endif} +{$endif} +end; + + +{$ifdef 32bit_SSE} +procedure Move20_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + mov eax, [eax+16] + movaps [edx], xmm0 + mov [edx+16], eax +{$else} + movups xmm0, [eax] + mov eax, [eax+16] + movups [edx], xmm0 + mov [edx+16], eax +{$endif} + xorps xmm0, xmm0 +end; +{$endif 32bit_SSE} + +procedure Move20(const ASource; var ADest; ACount: NativeInt); assembler;{$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov [edx + 4], ecx + mov ecx, [eax + 8] + mov [edx + 8], ecx + mov ecx, [eax + 12] + mov eax, [eax + 16] + mov [edx + 12], ecx + mov [edx + 16], eax +{$else} +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + mov ecx, [rcx + 16] + movdqa [rdx], xmm0 + mov [rdx + 16], ecx + {$else} + movdqa xmm0, [rdi] + mov edi, [rdi + 16] + movdqa [rsi], xmm0 + mov [rsi + 16], edi + {$endif} +{$else AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + mov ecx, [rcx + 16] + movdqu [rdx], xmm0 + mov [rdx + 16], ecx + {$else} + movdqu xmm0, [rdi] + mov edi, [rdi + 16] + movdqu [rsi], xmm0 + mov [rsi + 16], edi + {$endif} +{$endif} + xorps xmm0, xmm0 +{$endif 32Bit} +end; + +{$endif ExcludeSmallGranularMoves} + + +{$ifdef 64bit} +procedure Move24(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqa xmm0, [rcx] + mov r8, [rcx + 16] + movdqa [rdx], xmm0 + mov [rdx + 16], r8 + {$else} + movdqa xmm0, [rdi] + mov rdx, [rdi + 16] + movdqa [rsi], xmm0 + mov [rsi + 16], rdx + {$endif} +{$else} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqu xmm0, [rcx] + mov r8, [rcx + 16] + movdqu [rdx], xmm0 + mov [rdx + 16], r8 + {$else} + movdqu xmm0, [rdi] + mov rdx, [rdi + 16] + movdqu [rsi], xmm0 + mov [rsi + 16], rdx + {$endif} +{$endif} + xorps xmm0, xmm0 +end; +{$endif 64bit} + + +{$ifndef ExcludeSmallGranularMoves} + +{$ifdef 32bit_SSE} +procedure Move28_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler;{$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movups xmm1, [eax+12] + movaps [edx], xmm0 + movups [edx+12], xmm1 +{$else} + movups xmm0, [eax] + movups xmm1, [eax+12] + movups [edx], xmm0 + movups [edx+12], xmm1 +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +end; +{$endif 32bit_SSE} + +procedure Move28(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov [edx + 4], ecx + mov ecx, [eax + 8] + mov [edx + 8], ecx + mov ecx, [eax + 12] + mov [edx + 12], ecx + mov ecx, [eax + 16] + mov [edx + 16], ecx + mov ecx, [eax + 20] + mov eax, [eax + 24] + mov [edx + 20], ecx + mov [edx + 24], eax +{$else} + +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + mov r8, [rcx + 16] + mov ecx, [rcx + 24] + movdqa [rdx], xmm0 + mov [rdx + 16], r8 + mov [rdx + 24], ecx + {$else} + movdqa xmm0, [rdi] + mov rdx, [rdi + 16] + mov edi, [rdi + 24] + movdqa [rsi], xmm0 + mov [rsi + 16], rdx + mov [rsi + 24], edi + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + mov r8, [rcx + 16] + mov ecx, [rcx + 24] + movdqu [rdx], xmm0 + mov [rdx + 16], r8 + mov [rdx + 24], ecx + {$else} + movdqu xmm0, [rdi] + mov rdx, [rdi + 16] + mov edi, [rdi + 24] + movdqu [rsi], xmm0 + mov [rsi + 16], rdx + mov [rsi + 24], edi + {$endif} +{$endif} + xorps xmm0, xmm0 +{$endif} +end; + +{$ifdef 32bit_SSE} +procedure Move36_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + mov eax, [eax+32] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + mov [edx+32], eax +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + mov eax, [eax+32] + movups [edx], xmm0 + movups [edx+16], xmm1 + mov [edx+32], eax +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +end; +{$endif 32bit_SSE} + +procedure Move36(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + mov ecx, [eax + 32] + mov [edx + 32], ecx + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +{$else} + +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov ecx, [rcx + 32] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], ecx + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + mov edi, [rdi + 32] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + mov [rsi + 32], edi + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + mov ecx, [rcx + 32] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + mov [rdx + 32], ecx + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + mov edi, [rdi + 32] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + mov [rsi + 32], edi + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +{$endif} +end; + +{$ifdef 64bit} +procedure Move40(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov r8, [rcx + 32] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], r8 + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + mov rdx, [rdi + 32] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + mov [rsi + 32], rdx + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + mov r8, [rcx + 32] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + mov [rdx + 32], r8 + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + mov rdx, [rdi + 32] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + mov [rsi + 32], rdx + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +end; + +procedure Move48(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +end; + + +{$endif} + +{$ifdef 32bit_SSE} +procedure Move44_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movups xmm2, [eax+28] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movups [edx+28], xmm2 +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+28] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+28], xmm2 +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +end; +{$endif 32bit_SSE} + +procedure Move44(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + mov ecx, [eax + 40] + mov [edx + 40], ecx + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +{$else} + +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov r8, [rcx + 32] + mov ecx, [rcx + 40] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], r8 + mov [rdx + 40], ecx + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + mov rdx, [rdi + 32] + mov edi, [rdi + 40] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + mov [rsi + 32], rdx + mov [rsi + 40], edi + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + mov r8, [rcx + 32] + mov ecx, [rcx + 40] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + mov [rdx + 32], r8 + mov [rdx + 40], ecx + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + mov rdx, [rdi + 32] + mov edi, [rdi + 40] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + mov [rsi + 32], rdx + mov [rsi + 40], edi + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 +{$endif} +end; + + +{$ifdef 32bit_SSE} +procedure Move52_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + mov eax, [eax+48] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + mov [edx+48], eax +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + mov eax, [eax+48] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + mov [edx+48], eax +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +end; +{$endif 32bit_SSE} + +procedure Move52(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + mov ecx, [eax + 48] + mov [edx + 48], ecx + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +{$else} +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov ecx, [rcx + 48] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], ecx + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + mov edi, [rdi + 48] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + mov [rsi + 48], edi + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + mov ecx, [rcx + 48] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + mov [rdx + 48], ecx + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + mov edi, [rdi + 48] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + mov [rsi + 48], edi + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +{$endif} +end; + +{$endif ExcludeSmallGranularMoves} + + +{$ifdef 64bit} +procedure Move56(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov r8, [rcx + 48] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], r8 + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + mov rdx, [rdi + 48] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + mov [rsi + 48], rdx + {$endif} +{$else} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + mov r8, [rcx + 48] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + mov [rdx + 48], r8 + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + mov rdx, [rdi + 48] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + mov [rsi + 48], rdx + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +end; + + +procedure Move64(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + movdqa xmm3, [rcx + 48] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + movdqa [rdx + 48], xmm3 + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + movdqa xmm3, [rdi + 48] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + movdqa [rsi + 48], xmm3 + {$endif} +{$else} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + movdqu xmm3, [rcx + 48] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + movdqu [rdx + 48], xmm3 + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + movdqu xmm3, [rdi + 48] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + movdqu [rsi + 48], xmm3 + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 +end; + +{$endif 64bit} + +{$ifndef ExcludeSmallGranularMoves} + +{$ifdef 32bit_SSE} +procedure Move60_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + movups xmm3, [eax+44] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + movups [edx+44], xmm3 +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + movups xmm3, [eax+44] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + movups [edx+44], xmm3 +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 +end; +{$endif 32bit_SSE} + +procedure Move60(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + fild qword ptr [eax + 48] + mov ecx, [eax + 56] + mov [edx + 56], ecx + fistp qword ptr [edx + 48] + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +{$else} +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov r8, [rcx + 48] + mov ecx, [rcx + 56] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], r8 + mov [rdx + 56], ecx + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + mov rdx, [rdi + 48] + mov edi, [rdi + 56] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + mov [rsi + 48], rdx + mov [rsi + 56], edi + {$endif} +{$else} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + mov r8, [rcx + 48] + mov ecx, [rcx + 56] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + mov [rdx + 48], r8 + mov [rdx + 56], ecx + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + mov rdx, [rdi + 48] + mov edi, [rdi + 56] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + mov [rsi + 48], rdx + mov [rsi + 56], edi + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 +{$endif} +end; + +{$ifdef 32bit_SSE} +procedure Move68_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + movaps xmm3, [eax+48] + mov eax, [eax+64] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + movaps [edx+48], xmm3 + mov [edx+64], eax +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + movups xmm3, [eax+48] + mov eax, [eax+64] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + movups [edx+48], xmm3 + mov [edx+64], eax +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 +end; +{$endif 32bit_SSE} + +procedure Move68(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + fild qword ptr [eax + 48] + fild qword ptr [eax + 56] + mov ecx, [eax + 64] + mov [edx + 64], ecx + fistp qword ptr [edx + 56] + fistp qword ptr [edx + 48] + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +{$else 32Bit} +{$ifdef AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + movdqa xmm3, [rcx + 48] + mov ecx, [rcx + 64] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + movdqa [rdx + 48], xmm3 + mov [rdx + 64], ecx + {$else} + movdqa xmm0, [rdi] + movdqa xmm1, [rdi + 16] + movdqa xmm2, [rdi + 32] + movdqa xmm3, [rdi + 48] + mov edi, [rdi + 64] + movdqa [rsi], xmm0 + movdqa [rsi + 16], xmm1 + movdqa [rsi + 32], xmm2 + movdqa [rsi + 48], xmm3 + mov [rsi + 64], edi + {$endif} +{$else AlignAtLeast16Bytes} + {$ifndef unix} +.noframe + movdqu xmm0, [rcx] + movdqu xmm1, [rcx + 16] + movdqu xmm2, [rcx + 32] + movdqu xmm3, [rcx + 48] + mov ecx, [rcx + 64] + movdqu [rdx], xmm0 + movdqu [rdx + 16], xmm1 + movdqu [rdx + 32], xmm2 + movdqu [rdx + 48], xmm3 + mov [rdx + 64], ecx + {$else} + movdqu xmm0, [rdi] + movdqu xmm1, [rdi + 16] + movdqu xmm2, [rdi + 32] + movdqu xmm3, [rdi + 48] + mov edi, [rdi + 64] + movdqu [rsi], xmm0 + movdqu [rsi + 16], xmm1 + movdqu [rsi + 32], xmm2 + movdqu [rsi + 48], xmm3 + mov [rsi + 64], edi + {$endif} +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 +{$endif 32Bit} +end; + +{$ifdef 32bit_SSE} +procedure Move76_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + movaps xmm3, [eax+48] + movups xmm4, [eax+60] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + movaps [edx+48], xmm3 + movups [edx+60], xmm4 +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + movups xmm3, [eax+48] + movups xmm4, [eax+60] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + movups [edx+48], xmm3 + movups [edx+60], xmm4 +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 + xorps xmm4, xmm4 +end; +{$endif 32bit_SSE} + +{$ifdef 32bit_SSE} +procedure Move84_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + movaps xmm3, [eax+48] + movaps xmm4, [eax+64] + mov eax, [eax+80] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + movaps [edx+48], xmm3 + movaps [edx+64], xmm4 + mov [edx+80], eax +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + movups xmm3, [eax+48] + movups xmm4, [eax+64] + mov eax, [eax+80] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + movups [edx+48], xmm3 + movups [edx+64], xmm4 + mov [edx+80], eax +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 + xorps xmm4, xmm4 +end; +{$endif 32bit_SSE} + + +{$ifdef 32bit_SSE} +procedure Move92_32bit_SSE(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef AlignAtLeast16Bytes} + movaps xmm0, [eax] + movaps xmm1, [eax+16] + movaps xmm2, [eax+32] + movaps xmm3, [eax+48] + movaps xmm4, [eax+64] + movups xmm5, [eax+76] + movaps [edx], xmm0 + movaps [edx+16], xmm1 + movaps [edx+32], xmm2 + movaps [edx+48], xmm3 + movaps [edx+64], xmm4 + movups [edx+76], xmm5 +{$else} + movups xmm0, [eax] + movups xmm1, [eax+16] + movups xmm2, [eax+32] + movups xmm3, [eax+48] + movups xmm4, [eax+64] + movups xmm5, [eax+76] + movups [edx], xmm0 + movups [edx+16], xmm1 + movups [edx+32], xmm2 + movups [edx+48], xmm3 + movups [edx+64], xmm4 + movups [edx+76], xmm5 +{$endif} + xorps xmm0, xmm0 + xorps xmm1, xmm1 + xorps xmm2, xmm2 + xorps xmm3, xmm3 + xorps xmm4, xmm4 + xorps xmm5, xmm5 +end; +{$endif 32bit_SSE} + +{$endif ExcludeSmallGranularMoves} + + +{$ifndef PurePascal} +procedure MoveWithErmsNoAVX(const ASource; var ADest; ACount: NativeInt); forward; + + +{Variable size move procedure: Rounds ACount up to the next multiple of 16 less + SizeOf(Pointer). Important note: Always moves at least 16 - SizeOf(Pointer) + bytes (the minimum small block size with 16 byte alignment), irrespective of + ACount.} +procedure MoveX16LP(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + test FastMMCpuFeatures, FastMMCpuFeatureERMS + jz @NoERMS + call MoveWithErmsNoAVX + jmp @Finish +@NoERMS: + {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} + test FastMMCpuFeatures, FastMMCpuFeatureMMX + jz @FPUMove + {$endif} + {Make the counter negative based: The last 12 bytes are moved separately} + neg ecx + jns @MMXMoveLast12 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@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 Delphi4or5} + movq mm0, [eax + ecx] + movq mm1, [eax + ecx + 8] + movq [edx + ecx], mm0 + movq [edx + ecx + 8], mm1 + {$endif Delphi4or5} + {Are there another 16 bytes to move?} + add ecx, 16 + js @MMXMoveLoop + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MMXMoveLast12: + {Do the last 12 bytes} + {$ifdef Delphi4or5} + {Delphi 5 compatibility} + db $0f, $6f, $04, $01 + {$else Delphi4or5} + movq mm0, [eax + ecx] + {$endif Delphi4or5} + mov eax, [eax + ecx + 8] + {$ifdef Delphi4or5} + {Delphi 5 compatibility} + db $0f, $7f, $04, $11 + {$else Delphi4or5} + movq [edx + ecx], mm0 + {$endif Delphi4or5} + mov [edx + ecx + 8], eax + {Exit MMX state} + {$ifdef Delphi4or5} + {Delphi 5 compatibility} + db $0f, $77 + {$else Delphi4or5} + emms + {$endif Delphi4or5} + {$ifndef ForceMMX} + jmp @Finish + {$endif ForceMMX} +{$endif EnableMMX} +{FPU code is only used if MMX is not forced} +{$ifndef ForceMMX} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@FPUMove: + neg ecx + jns @FPUMoveLast12 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 ForceMMX} +{$else 32bit} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + test FastMMCpuFeatures, FastMMCpuFeatureERMS + jz @NoERMS + call MoveWithErmsNoAVX + jmp @Finish +@NoERMS: + {Make the counter negative based: The last 8 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@MoveLoop: + {Move a 16 byte block} +{$ifdef AlignAtLeast16Bytes} + movdqa xmm0, [rcx + r8] + movdqa [rdx + r8], xmm0 +{$else} + movdqu xmm0, [rcx + r8] + movdqu [rdx + r8], xmm0 +{$endif} + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoop + xorps xmm0, xmm0 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MoveLast8: + {Do the last 8 bytes} + mov r9, [rcx + r8] + mov [rdx + r8], r9 + {$else unix} + {Make the counter negative based: The last 8 bytes are moved separately} + sub rdx, 8 + add rdi, rdx + add rsi, rdx + neg rdx + jns @MoveLast8 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@MoveLoop: + {Move a 16 byte block} +{$ifdef AlignAtLeast16Bytes} + movdqa xmm0, [rdi + rdx] + movdqa [rsi + rdx], xmm0 +{$else} + movdqu xmm0, [rdi + rdx] + movdqu [rsi + rdx], xmm0 +{$endif} + {Are there another 16 bytes to move?} + add rdx, 16 + js @MoveLoop + xorps xmm0, xmm0 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@MoveLast8: + {Do the last 8 bytes} + mov rcx, [rdi + rdx] + mov [rsi + rdx], rcx + {$endif unix} +{$endif 32bit} +@Finish: +end; + + +{Variable size move procedure: Rounds ACount up to the next multiple of 32 less + SizeOf(Pointer). Important note: Always moves at least 32 - SizeOf(Pointer) + bytes (the minimum small block size with 16 byte alignment), irrespective of + ACount.} + +{$ifdef EnableAVX} + +procedure MoveX32LpAvx1NoErms(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {Make the counter negative based: The last 24 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + + db $C5, $F8, $77 // vzeroupper + + cmp r8, -128 + jg @SmallAvxMove + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} + +@AvxBigMoveAlignedAll: + db $C4, $C1, $7D, $6F, $04, $08 // vmovdqa ymm0, ymmword ptr [rcx+r8] + db $C4, $C1, $7D, $6F, $4C, $08, $20 // vmovdqa ymm1, ymmword ptr [rcx+r8+20h] + db $C4, $C1, $7D, $6F, $54, $08, $40 // vmovdqa ymm2, ymmword ptr [rcx+r8+40h] + db $C4, $C1, $7D, $6F, $5C, $08, $60 // vmovdqa ymm3, ymmword ptr [rcx+r8+60h] + db $C4, $C1, $7D, $7F, $04, $10 // vmovdqa ymmword ptr [rdx+r8], ymm0 + db $C4, $C1, $7D, $7F, $4C, $10, $20 // vmovdqa ymmword ptr [rdx+r8+20h], ymm1 + db $C4, $C1, $7D, $7F, $54, $10, $40 // vmovdqa ymmword ptr [rdx+r8+40h], ymm2 + db $C4, $C1, $7D, $7F, $5C, $10, $60 // vmovdqa ymmword ptr [rdx+r8+60h], ymm3 + add r8, 128 + cmp r8, -128 + jl @AvxBigMoveAlignedAll + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} + +@SmallAvxMove: + +@MoveLoopAvx: + {Move a 16 byte block} + db $C4, $A1, $79, $6F, $04, $01 // vmovdqa xmm0,xmmword ptr [rcx+r8] + db $C4, $A1, $79, $7F, $04, $02 // vmovdqa xmmword ptr [rdx+r8],xmm0 + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoopAvx + + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E4, $57, $DB // vxorps ymm3,ymm3,ymm3 + db $C5, $F8, $77 // vzeroupper + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} + +@MoveLast8: + {Do the last 8 bytes} + mov rcx, [rcx + r8] + mov [rdx + r8], rcx + {$else unix} + {MoveX32LP is not implemented for Unix yet, call the 16-byte version} + call MoveX16LP + {$endif unix} +@exit: +end; + +procedure MoveX32LpAvx2NoErms(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {Make the counter negative based: The last 24 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + + cmp r8, -128 + jg @SmallAvxMove + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} + +@AvxBigMoveAlignedAll: + db $C4, $C1, $7D, $6F, $04, $08 // vmovdqa ymm0, ymmword ptr [rcx+r8] + db $C4, $C1, $7D, $6F, $4C, $08, $20 // vmovdqa ymm1, ymmword ptr [rcx+r8+20h] + db $C4, $C1, $7D, $6F, $54, $08, $40 // vmovdqa ymm2, ymmword ptr [rcx+r8+40h] + db $C4, $C1, $7D, $6F, $5C, $08, $60 // vmovdqa ymm3, ymmword ptr [rcx+r8+60h] + db $C4, $C1, $7D, $7F, $04, $10 // vmovdqa ymmword ptr [rdx+r8], ymm0 + db $C4, $C1, $7D, $7F, $4C, $10, $20 // vmovdqa ymmword ptr [rdx+r8+20h], ymm1 + db $C4, $C1, $7D, $7F, $54, $10, $40 // vmovdqa ymmword ptr [rdx+r8+40h], ymm2 + db $C4, $C1, $7D, $7F, $5C, $10, $60 // vmovdqa ymmword ptr [rdx+r8+60h], ymm3 + add r8, 128 + cmp r8, -128 + jl @AvxBigMoveAlignedAll + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} + +@SmallAvxMove: + +@MoveLoopAvx: + {Move a 16 byte block} + db $C4, $A1, $79, $6F, $04, $01 // vmovdqa xmm0,xmmword ptr [rcx+r8] + db $C4, $A1, $79, $7F, $04, $02 // vmovdqa xmmword ptr [rdx+r8],xmm0 + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoopAvx + + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E5, $EF, $DB // vpxor ymm3,ymm3,ymm3 + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MoveLast8: + {Do the last 8 bytes} + mov rcx, [rcx + r8] + mov [rdx + r8], rcx + {$else unix} + {MoveX32LP is not implemented for Unix yet, call the 16-byte version} + call MoveX16LP + {$endif unix} +@exit: +end; + +{$ifdef EnableERMS} + +// According to the Intel Optimization Reference Manual (Section 3.7.6.2, Memcpy Considerations), rep movsb outperforms AVX copy on blocks of 2048 bytes and above + +const + cLeastErmsAdvantageLengh = 2048; + +procedure MoveX32LpAvx1WithErms(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {Make the counter negative based: The last 24 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + + cmp r8, 0-cLeastErmsAdvantageLengh + jg @DontDoRepMovsb + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} + +@DoRepMovsb: + mov rax, rsi + mov r9, rdi + lea rsi, [rcx+r8] + lea rdi, [rdx+r8] + neg r8 + add r8, 8 + mov rcx, r8 + cld + rep movsb + mov rdi, r9 + mov rsi, rax + jmp @exit + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@DontDoRepMovsb: + + db $C5, $F8, $77 // vzeroupper + + cmp r8, -128 + jg @SmallAvxMove + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@AvxBigMoveAlignedAll: + db $C4, $C1, $7D, $6F, $04, $08 // vmovdqa ymm0, ymmword ptr [rcx+r8] + db $C4, $C1, $7D, $6F, $4C, $08, $20 // vmovdqa ymm1, ymmword ptr [rcx+r8+20h] + db $C4, $C1, $7D, $6F, $54, $08, $40 // vmovdqa ymm2, ymmword ptr [rcx+r8+40h] + db $C4, $C1, $7D, $6F, $5C, $08, $60 // vmovdqa ymm3, ymmword ptr [rcx+r8+60h] + db $C4, $C1, $7D, $7F, $04, $10 // vmovdqa ymmword ptr [rdx+r8], ymm0 + db $C4, $C1, $7D, $7F, $4C, $10, $20 // vmovdqa ymmword ptr [rdx+r8+20h], ymm1 + db $C4, $C1, $7D, $7F, $54, $10, $40 // vmovdqa ymmword ptr [rdx+r8+40h], ymm2 + db $C4, $C1, $7D, $7F, $5C, $10, $60 // vmovdqa ymmword ptr [rdx+r8+60h], ymm3 + add r8, 128 + cmp r8, -128 + jl @AvxBigMoveAlignedAll + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@SmallAvxMove: + +@MoveLoopAvx: + {Move a 16 byte block} + db $C4, $A1, $79, $6F, $04, $01 // vmovdqa xmm0,xmmword ptr [rcx+r8] + db $C4, $A1, $79, $7F, $04, $02 // vmovdqa xmmword ptr [rdx+r8],xmm0 + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoopAvx + + db $C5, $FC, $57, $C0 // vxorps ymm0,ymm0,ymm0 + db $C5, $F4, $57, $C9 // vxorps ymm1,ymm1,ymm1 + db $C5, $EC, $57, $D2 // vxorps ymm2,ymm2,ymm2 + db $C5, $E4, $57, $DB // vxorps ymm3,ymm3,ymm3 + db $C5, $F8, $77 // vzeroupper + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} + +@MoveLast8: + {Do the last 8 bytes} + mov rcx, [rcx + r8] + mov [rdx + r8], rcx + {$else unix} + {MoveX32LP is not implemented for Unix yet, call the 16-byte version} + call MoveX16LP + {$endif unix} +@exit: +end; + +procedure MoveX32LpAvx2WithErms(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {Make the counter negative based: The last 24 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + + cmp r8, 0-cLeastErmsAdvantageLengh + jg @DontDoRepMovsb + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} + +@DoRepMovsb: + mov rax, rsi + mov r9, rdi + lea rsi, [rcx+r8] + lea rdi, [rdx+r8] + neg r8 + add r8, 8 + mov rcx, r8 + cld + rep movsb + mov rdi, r9 + mov rsi, rax + jmp @exit + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@DontDoRepMovsb: + cmp r8, -128 + jg @SmallAvxMove + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@AvxBigMoveAlignedAll: + db $C4, $C1, $7D, $6F, $04, $08 // vmovdqa ymm0, ymmword ptr [rcx+r8] + db $C4, $C1, $7D, $6F, $4C, $08, $20 // vmovdqa ymm1, ymmword ptr [rcx+r8+20h] + db $C4, $C1, $7D, $6F, $54, $08, $40 // vmovdqa ymm2, ymmword ptr [rcx+r8+40h] + db $C4, $C1, $7D, $6F, $5C, $08, $60 // vmovdqa ymm3, ymmword ptr [rcx+r8+60h] + db $C4, $C1, $7D, $7F, $04, $10 // vmovdqa ymmword ptr [rdx+r8], ymm0 + db $C4, $C1, $7D, $7F, $4C, $10, $20 // vmovdqa ymmword ptr [rdx+r8+20h], ymm1 + db $C4, $C1, $7D, $7F, $54, $10, $40 // vmovdqa ymmword ptr [rdx+r8+40h], ymm2 + db $C4, $C1, $7D, $7F, $5C, $10, $60 // vmovdqa ymmword ptr [rdx+r8+60h], ymm3 + add r8, 128 + cmp r8, -128 + jl @AvxBigMoveAlignedAll + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} + +@SmallAvxMove: + +@MoveLoopAvx: + {Move a 16 byte block} + db $C4, $A1, $79, $6F, $04, $01 // vmovdqa xmm0,xmmword ptr [rcx+r8] + db $C4, $A1, $79, $7F, $04, $02 // vmovdqa xmmword ptr [rdx+r8],xmm0 + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoopAvx + + db $C5, $FD, $EF, $C0 // vpxor ymm0,ymm0,ymm0 + db $C5, $F5, $EF, $C9 // vpxor ymm1,ymm1,ymm1 + db $C5, $ED, $EF, $D2 // vpxor ymm2,ymm2,ymm2 + db $C5, $E5, $EF, $DB // vpxor ymm3,ymm3,ymm3 + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} + +@MoveLast8: + {Do the last 8 bytes} + mov rcx, [rcx + r8] + mov [rdx + r8], rcx + {$else unix} + {MoveX32LP is not implemented for Unix yet, call the 16-byte version} + call MoveX16LP + {$endif unix} +@exit: +end; +{$endif EnableERMS} + +{$endif EnableAVX} + + +{$ifdef EnableERMS} + +{This routine is only called with the CPU supports "Enhanced REP MOVSB/STOSB", +see "Intel 64 and IA-32 Architectures Optimization Reference Manual +p. 3.7.7 (Enhanced REP MOVSB and STOSB operation (ERMSB)). +We first check the corresponding bit in the CPUID, and, if it is supported, +call this routine.} + +const + cAlignErmsDestinationBits = 6; + cAlignErmsDestinationBoundary = (1 shl cAlignErmsDestinationBits); + cAlignErmsDestinationMask = cAlignErmsDestinationBoundary-1; + + cRoundErmsBlockSizeBits = 6; + cRoundErmsBlockSizeBoundary = (1 shl cRoundErmsBlockSizeBits); + cRoundErmsBlockSizeMask = cRoundErmsBlockSizeBoundary-1; + + cRepMovsSmallBlock = Cardinal(cRoundErmsBlockSizeBoundary) * 3; + +procedure MoveWithErmsNoAVX(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} +// Under 32-bit Windows or Unix, the call passes first parametr in EAX, second in EDX, third in ECX + + push ebx + push esi + push edi + mov esi, eax + mov edi, edx + + cmp ecx, cRepMovsSmallBlock + jbe @SmallBlock +// test destination alignment + mov eax, edi + and eax, cAlignErmsDestinationMask + jz @DestinationAligned + mov ebx, ecx + mov ecx, cAlignErmsDestinationBoundary + sub ecx, eax + sub ebx, ecx + +@again: + mov eax, [esi] + mov edx, [esi+4] + mov [edi], eax + mov [edi+4], edx + add esi, 8 + add edi, 8 + sub ecx, 8 + jg @again + add ebx, ecx + add esi, ecx + add edi, ecx + mov ecx, ebx + +@DestinationAligned: + +// test block size rounding + mov eax, ecx + and eax, cRoundErmsBlockSizeMask + jz @SingleMove // the block size is aligned + sub ecx, eax + shr ecx, 2 + cld + rep movsd + mov ecx, eax + jmp @SmallBlock + +@SingleMove: + shr ecx, 2 + cld + rep movsd + jmp @finish + +@SmallBlock: + +// on 32-bit, fast short strings do not work, at least on Ice Lake + + cmp ecx, 8 + jb @below8left + +{$ifdef 32bit_SSE} + cmp ecx, 32 + jb @below32left + + test FastMMCpuFeatures, FastMMCpuFeatureSSE + jz @NoSSE // no SSE + + sub ecx, 32 +@LoopSSE: + movups xmm0, [esi+16*0] + movups xmm1, [esi+16*1] + movups [edi+16*0], xmm0 + movups [edi+16*1], xmm1 + add esi, 32 + add edi, 32 + sub ecx, 32 + jge @LoopSSE + xorps xmm0, xmm0 + xorps xmm1, xmm1 + add ecx, 32 + jz @finish + + +@NoSSE: +{$endif} + +@below32left: + sub ecx, 8 + js @below8left_add + +@again3: + mov eax, [esi] + mov edx, [esi+4] + mov [edi], eax + mov [edi+4], edx + add esi, 8 + add edi, 8 + sub ecx, 8 + jge @again3 + +@below8left_add: + add ecx, 8 + +@below8left: + jz @finish + +@loop4: + mov eax, [esi] + mov [edi], eax + add esi, 4 + add edi, 4 + sub ecx, 4 + jg @loop4 + +@finish: + pop edi + pop esi + pop ebx + +{$else} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + +// under Win64, first - RCX, second - RDX, third R8; the caller must preserve RSI and RDI + + cmp r8, 32 + ja @beg + +// try a small move of up to 32 bytes +@again0: + mov rax, [rcx] + mov [rdx], rax + add rcx, 8 + add rdx, 8 + sub r8, 8 + jg @again0 + jmp @exit + +@beg: + mov r9, rsi // save rsi + mov r10, rdi // save rdi + mov rsi, rcx + mov rdi, rdx + mov rcx, r8 + + cmp rcx, cRepMovsSmallBlock + jbe @SmallBlock +// test destination alignment + mov rax, rdi + and rax, cAlignErmsDestinationMask + jz @DestinationAligned + mov r8, rcx + mov rcx, cAlignErmsDestinationBoundary + sub rcx, rax + sub r8, rcx + +@again: + mov rax, [rsi] + mov rdx, [rsi+8] + mov [rdi], rax + mov [rdi+8], rdx + add rsi, 16 + add rdi, 16 + sub rcx, 16 + jg @again + add r8, rcx + add rsi, rcx + add rdi, rcx + mov rcx, r8 + +@DestinationAligned: + +// test block size rounding + mov rax, rcx + and rax, cRoundErmsBlockSizeMask + jz @SingleMove // the block size is aligned + sub rcx, rax + shr rcx, 3 + cld + rep movsq + mov rcx, rax + jmp @TailAfterMovs + +@SingleMove: + shr rcx, 3 + cld + rep movsq + jmp @finish + +{$ifdef EnableFSRM} +@movs: + cld + rep movsb + jmp @finish +{$endif} + +@SmallBlock: + cmp rcx, 64 + jbe @Left64OrLess + +{$ifndef fpc} +{$ifdef EnableFSRM} + // moves of 64 bytes or less are good only when we have fast short strings on 64 bit, + // but not on 32 bit + test FastMMCpuFeatures, FastMMCpuFeatureFSRM + jnz @movs +{$endif} +{$endif} + +@Left64OrLess: + +@TailAfterMovs: + cmp rcx, 16 + jb @below16left + sub rcx, 16 +@again3: + mov rax, [rsi] + mov rdx, [rsi+8] + mov [rdi], rax + mov [rdi+8], rdx + add rsi, 16 + add rdi, 16 + sub rcx, 16 + jge @again3 + add rcx, 16 + +@below16left: + jz @finish + +@again2: + mov eax, [rsi] + mov [rdi], eax + add rsi, 4 + add rdi, 4 + sub rcx, 4 + jg @again2 +@finish: + mov rsi, r9 + mov rdi, r10 + {$else} +// Under Unix 64 the first 3 arguments are passed in RDI, RSI, RDX + mov rcx, rsi + mov rsi, rdi + mov rdi, rcx + mov rcx, rdx + cld + rep movsb + {$endif} +{$endif} +@exit: +end; + +{$endif EnableERMS} + +{$ifdef Align32Bytes} +procedure MoveX32LpUniversal(const ASource; var ADest; ACount: NativeInt); +var + F: Byte; +begin +{$ifdef USE_CPUID} + F := FastMMCpuFeatures; +{$ifdef EnableFSRM} + if F and FastMMCpuFeatureFSRM <> 0 then + begin + MoveWithErmsNoAVX(ASource, ADest, ACount); + end else +{$endif} + {$ifdef EnableAVX} + if (F and FastMMCpuFeatureAVX2) <> 0 then + begin + {$ifdef EnableERMS} + if (F and FastMMCpuFeatureERMS) <> 0 then + begin + {$ifdef EnableAVX512} + {$ifndef DisableMoveX32LpAvx512} + if (F and FastMMCpuFeatureAVX512) <> 0 then + begin + MoveX32LpAvx512WithErms(ASource, ADest, ACount) + end + else + {$endif} + {$endif} + begin + MoveX32LpAvx2WithErms(ASource, ADest, ACount) + end; + end else + {$endif} + begin + MoveX32LpAvx2NoErms(ASource, ADest, ACount) + end; + end else + if (F and FastMMCpuFeatureAVX1) <> 0 then + begin + {$ifdef EnableERMS} + if (F and FastMMCpuFeatureERMS) <> 0 then + begin + MoveX32LpAvx1WithErms(ASource, ADest, ACount) + end else + {$endif} + begin + MoveX32LpAvx1NoErms(ASource, ADest, ACount) + end; + end else + {$endif EnableAVX} + begin + {$ifdef EnableERMS} + if (F and FastMMCpuFeatureERMS) <> 0 then + begin + MoveWithErmsNoAVX(ASource, ADest, ACount) + end else + {$endif} + begin + MoveX16LP(ASource, ADest, ACount) + end; + end; +{$else} + MoveX16LP(ASource, ADest, ACount) +{$endif} +end; +{$endif} + +{Variable size move procedure: Rounds ACount up to the next multiple of 8 less + SizeOf(Pointer). Important note: Always moves at least 8 - SizeOf(Pointer) + bytes (the minimum small block size with 8 byte alignment), irrespective of + ACount.} +procedure MoveX8LP(const ASource; var ADest; ACount: NativeInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + test FastMMCpuFeatures, FastMMCpuFeatureERMS + jz @NoERMS + call MoveWithErmsNoAVX + jmp @Finish + +@NoERMS: + {Make the counter negative based: The last 4 bytes are moved separately} + sub ecx, 4 + {4 bytes or less? -> Use the Move4 routine.} + jle @FourBytesOrLess + add eax, ecx + add edx, ecx + neg ecx +{$ifdef EnableMMX} + {$ifndef ForceMMX} + test FastMMCpuFeatures, FastMMCpuFeatureMMX + jz @FPUMoveLoop + {$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$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 + jmp @Finish +{$endif} +{FPU code is only used if MMX is not forced} +{$ifndef ForceMMX} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} + +@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 + jmp @Finish +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@FourBytesOrLess: + {Four or less bytes to move} + mov eax, [eax] + mov [edx], eax +{$else} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + {Make the counter negative based} + add rcx, r8 + add rdx, r8 + neg r8 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@MoveLoop: + {Move an 8 byte block} + mov r9, [rcx + r8] + mov [rdx + r8], r9 + {Are there another 8 bytes to move?} + add r8, 8 + js @MoveLoop + {$else} + {Make the counter negative based} + add rdi, rdx + add rsi, rdx + neg rdx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@MoveLoop: + {Move an 8 byte block} + mov rcx, [rdi + rdx] + mov [rsi + rdx], rcx + {Are there another 8 bytes to move?} + add rdx, 8 + js @MoveLoop + {$Endif} +{$endif} +@Finish: +end; + +{$endif ASMVersion} + +{----------------Windows Emulation Functions for Kylix / OS X Support-----------------} + +{$ifdef POSIX} + +const + {Messagebox constants} + MB_OK = 0; + MB_ICONERROR = $10; + MB_TASKMODAL = $2000; + MB_DEFAULT_DESKTOP_ONLY = $20000; + {Virtual memory constants} + MEM_COMMIT = $1000; + MEM_RELEASE = $8000; + MEM_TOP_DOWN = $100000; + PAGE_READWRITE = 4; + +procedure MessageBoxA(hWnd: Cardinal; AMessageText, AMessageTitle: PAnsiChar; uType: Cardinal); stdcall; +begin + if FastMMIsInstalled then + writeln(AMessageText) + else + {$ifndef fpc} + __write(STDERR_FILENO, AMessageText, StrLen(AMessageText)); + {$else} + FpWrite(StdErrorHandle, AMessageText, StrLen(AMessageText)); + {$endif} +end; + +{$ifndef MACOS} +function VirtualAlloc(lpvAddress: Pointer; dwSize, flAllocationType, flProtect: Cardinal): Pointer; stdcall; +begin + Result := valloc(dwSize); +end; + +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall; +begin + free(lpAddress); + Result := True; +end; +{$endif} + +function WriteFile(hFile: THandle; const Buffer; nNumberOfBytesToWrite: Cardinal; + var lpNumberOfBytesWritten: Cardinal; lpOverlapped: Pointer): Boolean; stdcall; +begin + {$ifndef fpc} + lpNumberOfBytesWritten := __write(hFile, {$ifdef MACOS}@Buffer{$else}Buffer{$endif}, + nNumberOfBytesToWrite); + {$else} + lpNumberOfBytesWritten := fpwrite(hFile, Buffer, nNumberOfBytesToWrite); + {$endif} + if lpNumberOfBytesWritten = Cardinal(-1) then + begin + lpNumberOfBytesWritten := 0; + Result := False; + end + else + Result := True; +end; + +{$ifndef NeverSleepOnThreadContention} +procedure Sleep(dwMilliseconds: Cardinal); stdcall; +begin + {Convert to microseconds (more or less)} + usleep(dwMilliseconds shl 10); +end; +{$endif} +{$endif} + +{-----------------Debugging Support Functions and Procedures------------------} + +{$ifdef FullDebugMode} + +{Returns the current thread ID} +function GetThreadID: Cardinal; +{$ifdef WIN32} +asm + mov eax, FS:[$24] +end; +{$else} +begin + Result := GetCurrentThreadId; +end; +{$endif} + +{Fills a block of memory with the given dword (32-bit) or qword (64-bit). + Always fills a multiple of SizeOf(Pointer) bytes} +procedure DebugFillMem(var AAddress; AByteCount: NativeInt; AFillValue: NativeUInt); assembler; {$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 32Bit} + {On Entry: + eax = AAddress + edx = AByteCount + ecx = AFillValue} + add eax, edx + neg edx + jns @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@FillLoop: + mov [eax + edx], ecx + add edx, 4 + js @FillLoop +@Done: +{$else 32Bit} + {$ifndef unix} +.noframe + {On Entry: + rcx = AAddress + rdx = AByteCount + r8 = AFillValue} + add rcx, rdx + neg rdx + jns @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@FillLoop: + mov [rcx + rdx], r8 + add rdx, 8 + js @FillLoop +@Done: + {$else unix} + {On Entry: + rdi = AAddress + rsi = AByteCount + rdx = AFillValue} + add rdi, rsi + neg rsi + jns @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@FillLoop: + mov [rdi + rsi], rdx + add rsi, 8 + js @FillLoop +@Done: + {$endif unix} +{$endif 32Bit} +end; +{$endif} + +{$ifdef _StackTracer} +{------------------------Stack tracer---------------------------} + + {$ifndef LoadDebugDLLDynamically} + +{The stack trace procedure. The stack trace module is external since it may + raise handled access violations that result in the creation of exception + objects and the stack trace code is not re-entrant.} +procedure GetStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName + name {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif}; + +{The exported procedure in the FastMM_FullDebugMode.dll library used to convert + the return addresses of a stack trace to a text string.} +function LogStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; external FullDebugModeLibraryName + name 'LogStackTrace'; + + {$else} + + {Default no-op stack trace and logging handlers} + procedure NoOpGetStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); + begin + DebugFillMem(AReturnAddresses^, AMaxDepth * SizeOf(Pointer), 0); + end; + + function NoOpLogStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; + begin + Result := ABuffer; + end; + +var + + {Handle to the FullDebugMode DLL} + FullDebugModeDLL: HMODULE; + + GetStackTrace: procedure (AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal) = NoOpGetStackTrace; + + LogStackTrace: function (AReturnAddresses: PNativeUInt; + AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar = NoOpLogStackTrace; + + {$endif} + +{$endif} + +{$ifdef UseReleaseStack } +function GetStackSlot: DWORD; +begin +// http://burtleburtle.net/bob/hash/integer.html + Result := GetCurrentThreadID; + Result := (Result xor 61) xor (Result shr 16); + Result := Result + (Result shl 3); + Result := Result xor (Result shr 4); + Result := Result * $27d4eb2d; + Result := Result xor (Result shr 15); + Result := Result and (NumStacksPerBlock - 1); +end; +{$endif} + +{$ifndef POSIX} +function DelphiIsRunning: Boolean; +begin + Result := FindWindowA('TAppBuilder', nil) <> 0; +end; +{$endif} + +{Converts an unsigned integer to string at the buffer location, returning the + new buffer position. Note: The 32-bit assembler version only supports numbers + up to 2^31 - 1.} + + +{Input: + ANum - the NativeUInt value to convert ; + APBuffer - output buffer; + ABufferLengthChars - the size of the output buffer in characters (not in bytes); + since currently one char is one byte, the maxiumum lenght + of the buffer in characters is the same as the size of the + buffer in bytes, but if we switch to double-byte charaters + in future (e.g. UTF-16), this will differ} + +function NativeUIntToStrBuf(ANum: NativeUInt; APBuffer: PAnsiChar; ABufferLengthChars: Cardinal): PAnsiChar; +{$ifndef Use32BitAsm} +const + MaxDigits = 20; +var + LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar; + LCount: Cardinal; + LIndex: Cardinal; + LDigit: NativeUInt; + LNum: NativeUInt; +begin + {Generate the digits in the local buffer} + LNum := ANum; + LCount := 0; + repeat + LDigit := LNum; + LNum := LNum div 10; + LDigit := LDigit - LNum * 10; + Inc(LCount); + LIndex := MaxDigits - LCount; + LDigitBuffer[LIndex] := AnsiChar(Ord('0') + LDigit); + until (LNum = 0) or (LIndex = 0); + {Copy the digits to the output buffer and advance it} + if LCount < ABufferLengthChars then + begin + System.Move(LDigitBuffer[LIndex], APBuffer^, LCount*SizeOf(APBuffer[0])); + Result := APBuffer + LCount; + end else + begin + Result := APBuffer; + Result^ := #0; + end; +end; +{$else} +assembler; +asm + {On entry: eax = ANum, edx = APBuffer, ecx = ABufferLengthChars} + {todo: implement ecx(ABufferLengthChars) checking for BASM} + push edi + mov edi, edx //Pointer to the first character in edi + {Calculate leading digit: divide the number by 1e9} + add eax, 1 //Increment the number + mov edx, $89705F41 //1e9 reciprocal + mul edx //Multplying with reciprocal + shr eax, 30 //Save fraction bits + mov ecx, edx //First digit in bits <31:29> + and edx, $1FFFFFFF //Filter fraction part edx<28:0> + shr ecx, 29 //Get leading digit into accumulator + lea edx, [edx + 4 * edx] //Calculate ... + add edx, eax //... 5*fraction + mov eax, ecx //Copy leading digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #2} + mov eax, edx //Point format such that 1.0 = 2^28 + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 28 //Next digit + and edx, $0fffffff //Fraction part edx<27:0> + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #3} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:27> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<26:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 27 //Next digit + and edx, $07ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #4} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:26> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<25:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 26 //Next digit + and edx, $03ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #5} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:25> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<24:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 25 //Next digit + and edx, $01ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #6} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:24> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<23:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 24 //Next digit + and edx, $00ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #7} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:23> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<31:23> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 23 //Next digit + and edx, $007fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #8} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:22> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<22:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 22 //Next digit + and edx, $003fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #9} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:21> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<21:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 21 //Next digit + and edx, $001fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #10} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:20> + cmp ecx, 1 //Any-non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 20 //Next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store last digit and end marker out to memory + {Return a pointer to the next character} + lea eax, [edi + 1] + {Restore edi} + pop edi +end; +{$endif} + +{Converts an unsigned integer to a hexadecimal string at the buffer location, + returning the new buffer position.} +function NativeUIntToHexBuf(ANum: NativeUInt; APBuffer: PAnsiChar; ABufferLengthChars: Cardinal): PAnsiChar; +{$ifndef Use32BitAsm} +const + MaxDigits = 16; +var + LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar; + LCount: Cardinal; + LIndex: Cardinal; + LDigit: NativeUInt; + LNum: NativeUInt; +begin + {Generate the digits in the local buffer} + LNum := ANum; + LCount := 0; + repeat + LDigit := LNum; + LNum := LNum shr 4 {div 16}; + LDigit := LDigit - (LNum shl 4) { * 16}; + Inc(LCount); + LIndex := MaxDigits - LCount; + LDigitBuffer[LIndex] := HexTable[LDigit]; + until (LNum = 0) or (LIndex = 0); + {Copy the digits to the output buffer and advance it} + if LCount < ABufferLengthChars then + begin + System.Move(LDigitBuffer[LIndex], APBuffer^, LCount*SizeOf(LDigitBuffer[0])); + Result := APBuffer + LCount; + end else + begin + Result := APBuffer; + Result^ := #0; + end; +end; +{$else} +assembler; +asm + {On entry: + eax = ANum + edx = ABuffer + ecx = ABufferLengthChars} + + {todo: implement ecx(ABufferLengthChars) checking} + + push ebx + push edi + {Save ANum in ebx} + mov ebx, eax + {Get a pointer to the first character in edi} + mov edi, edx + {Get the number in ecx as well} + mov ecx, eax + {Keep the low nibbles in ebx and the high nibbles in ecx} + and ebx, $0f0f0f0f + and ecx, $f0f0f0f0 + {Swap the bytes into the right order} + ror ebx, 16 + ror ecx, 20 + {Get nibble 7} + movzx eax, ch + mov dl, ch + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 6} + movzx eax, bh + or dl, bh + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 5} + movzx eax, cl + or dl, cl + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 4} + movzx eax, bl + or dl, bl + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Rotate ecx and ebx so we get access to the rest} + shr ebx, 16 + shr ecx, 16 + {Get nibble 3} + movzx eax, ch + or dl, ch + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 2} + movzx eax, bh + or dl, bh + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 1} + movzx eax, cl + or dl, cl + mov al, byte ptr HexTable[eax] + mov [edi], al + cmp dl, 1 + sbb edi, -1 + {Get nibble 0} + movzx eax, bl + mov al, byte ptr HexTable[eax] + mov [edi], al + {Return a pointer to the end of the string} + lea eax, [edi + 1] + {Restore registers} + pop edi + pop ebx +end; +{$endif} + +{Appends the source text to the destination and returns the new destination + position} +function AppendStringToBuffer(const ASource, ADestination: PAnsiChar; + ASourceLengthChars, ADestinationBufferLengthChars: Cardinal): PAnsiChar; +begin + Result := ADestination; + if ASourceLengthChars > 0 then + begin + if (ASourceLengthChars <= ADestinationBufferLengthChars) and + (ASourceLengthChars < MaxInt div SizeOf(ASource[0])) and + (ADestinationBufferLengthChars < MaxInt div SizeOf(ASource[0])) then + begin + System.Move(ASource^, ADestination^, ASourceLengthChars*SizeOf(ASource[0])); + Result := ADestination; + Inc(Result, ASourceLengthChars); + end else + begin + Result^ := #0; + end; + end else + begin + Result^ := #0; + end; +end; + +{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName} +type + PClassData = ^TClassData; + TClassData = record + ClassType: TClass; + ParentInfo: Pointer; + PropCount: SmallInt; + UnitName: ShortString; + end; +{$endif EnableMemoryLeakReportingUsesQualifiedClassName} + +{Appends the name of the class to the destination buffer and returns the new + destination position} +function AppendClassNameToBuffer(AClass: TClass; ADestination: PAnsiChar; ADestinationBufferLengthChars: Cardinal): PAnsiChar; +var +{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName} + FirstUnitNameChar: PAnsiChar; + LClassInfo: Pointer; + LClassInfoPByte: PByte; + LClassInfoByte1: Byte; + UnitName: PShortString; + LClassData: PClassData; +{$endif EnableMemoryLeakReportingUsesQualifiedClassName} + LPClassName: PShortString; +begin + {Get a pointer to the class name} + if AClass <> nil then + begin + Result := ADestination; +{$ifdef EnableMemoryLeakReportingUsesQualifiedClassName} + // based on TObject.UnitScope + LClassInfo := AClass.ClassInfo; + if LClassInfo <> nil then // prepend the UnitName + begin + LClassInfoPByte := LClassInfo; + LClassInfoByte1 := {$ifdef PByteIsPAnsiChar}Byte{$endif}(PByte(LClassInfoPByte + 1)^); + Inc(LClassInfoPByte, 2); + Inc(LClassInfoPByte, LClassInfoByte1); + LClassData := PClassData(LClassInfoPByte); + UnitName := @(LClassData^.UnitName); + FirstUnitNameChar := @(UnitName^[1]); + if FirstUnitNameChar^ <> '@' then + Result := AppendStringToBuffer(FirstUnitNameChar, Result, Length(UnitName^), ADestinationBufferLengthChars) + else // Pos does no memory allocations, so it is safe to use + begin // Skip the '@', then copy until the ':' - never seen this happen in Delphi, but might be a C++ thing + Result := AppendStringToBuffer(@(UnitName^[2]), Result, Pos(ShortString(':'), UnitName^) - 2, ADestinationBufferLengthChars) + ; + end; + // dot between unit name and class name: + Result := AppendStringToBuffer('.', Result, Length('.'), ADestinationBufferLengthChars); + end; +{$endif EnableMemoryLeakReportingUsesQualifiedClassName} + LPClassName := PShortString(PPointer(PByte(AClass) + vmtClassName)^); + {Append the class name} + Result := AppendStringToBuffer(@LPClassName^[1], Result, Length(LPClassName^), ADestinationBufferLengthChars); + end + else + begin + Result := AppendStringToBuffer(UnknownClassNameMsg, ADestination, Length(UnknownClassNameMsg), ADestinationBufferLengthChars); + end; +end; + +{Shows a message box if the program is not showing one already.} +procedure ShowMessageBox(AText, ACaption: PAnsiChar); +begin + if (not ShowingMessageBox) and (not SuppressMessageBoxes) then + begin + ShowingMessageBox := True; + MessageBoxA(0, AText, ACaption, + MB_OK or MB_ICONERROR or MB_TASKMODAL or MB_DEFAULT_DESKTOP_ONLY); + ShowingMessageBox := False; + end; +end; + +{Returns the class for a memory block. Returns nil if it is not a valid class} +function DetectClassInstance(APointer: Pointer): TClass; +{$ifdef VmtSupported} +var + LMemInfo: TMemoryBasicInformation; + + {Checks whether the given address is a valid address for a VMT entry.} + function IsValidVMTAddress(APAddress: Pointer): Boolean; + begin + {Do some basic pointer checks: Must be dword aligned and beyond 64K} + if (UIntPtr(APAddress) > 65535) + and ((UIntPtr(APAddress) and 3) = 0) then + begin + {Do we need to recheck the virtual memory?} + if (UIntPtr(LMemInfo.BaseAddress) > UIntPtr(APAddress)) + or ((UIntPtr(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (UIntPtr(APAddress) + 4)) then + begin + {Get the VM status for the pointer} + LMemInfo.RegionSize := 0; + VirtualQuery(APAddress, LMemInfo, SizeOf(LMemInfo)); + end; + {Check the readability of the memory address} + Result := (LMemInfo.RegionSize >= 4) + and (LMemInfo.State = MEM_COMMIT) + and ((LMemInfo.Protect and (PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY)) <> 0) + and ((LMemInfo.Protect and PAGE_GUARD) = 0); + end + else + Result := False; + end; + + {Returns true if AClassPointer points to a class VMT} + function InternalIsValidClass(AClassPointer: Pointer; ADepth: Integer = 0): Boolean; + var + LParentClassSelfPointer: PPointer; + begin + {Check that the self pointer as well as parent class self pointer addresses + are valid} + if (ADepth < 1000) + and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtSelfPtr)) + and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtParent)) then + begin + {Get a pointer to the parent class' self pointer} + LParentClassSelfPointer := PPointer(PByte(AClassPointer) + vmtParent)^; + {Check that the self pointer as well as the parent class is valid} + Result := (PPointer(PByte(AClassPointer) + vmtSelfPtr)^ = AClassPointer) + and ((LParentClassSelfPointer = nil) + or (IsValidVMTAddress(LParentClassSelfPointer) + and InternalIsValidClass(LParentClassSelfPointer^, ADepth + 1))); + end + else + Result := False; + end; + +begin + {Get the class pointer from the (suspected) object} + Result := TClass(PPointer(APointer)^); + {No VM info yet} + LMemInfo.RegionSize := 0; + {Check the block} + if (not InternalIsValidClass(Pointer(Result), 0)) +{$ifdef FullDebugMode} + or (Pointer(Result) = @(FreedObjectVMT.VMTMethods[0])) +{$endif} + then + Result := nil; +end; +{$else VmtSupported} +begin + {Not currently supported under Linux / OS X} + Result := nil; +end; +{$endif VmtSupported} + +{Gets the available size inside a block} +function GetAvailableSpaceInBlock(APointer: Pointer): NativeUInt; +var + LBlockHeader: NativeUInt; + LPSmallBlockPool: PSmallBlockPoolHeader; +begin + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + if (LBlockHeader and (IsMediumBlockFlag or IsLargeBlockFlag)) = 0 then + begin + LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader and DropSmallFlagsMask); + Result := LPSmallBlockPool^.BlockType^.BlockSize - BlockHeaderSize; + end + else + begin + Result := (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize; + if (LBlockHeader and IsMediumBlockFlag) = 0 then + Dec(Result, LargeBlockHeaderSize); + end; +end; + +{-----------------Small Block Management------------------} + +{Locks all small block types} +procedure LockAllSmallBlockTypes; +var + LIndC: Cardinal; +begin + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + for LIndC := 0 to NumSmallBlockTypes - 1 do + begin + while not AcquireLockByte(SmallBlockTypes[LIndC].SmallBlockTypeLocked) do + begin +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} +{$else} + Sleep(InitialSleepTime); + if AcquireLockByte(SmallBlockTypes[LIndC].SmallBlockTypeLocked) then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; + end; + end; +end; + +{Gets the first and last block pointer for a small block pool} +procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader; + var AFirstPtr, ALastPtr: Pointer); +var + LBlockSize: NativeUInt; +begin + {Get the pointer to the first block} + AFirstPtr := Pointer(PByte(APSmallBlockPool) + SmallBlockPoolHeaderSize); + {Get a pointer to the last block} + if (APSmallBlockPool^.BlockType^.CurrentSequentialFeedPool <> APSmallBlockPool) + or (UIntPtr(APSmallBlockPool^.BlockType^.NextSequentialFeedBlockAddress) > UIntPtr(APSmallBlockPool^.BlockType^.MaxSequentialFeedBlockAddress)) then + begin + {Not the sequential feed - point to the end of the block} + LBlockSize := PNativeUInt(PByte(APSmallBlockPool) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + ALastPtr := Pointer(PByte(APSmallBlockPool) + LBlockSize - APSmallBlockPool^.BlockType^.BlockSize); + end + else + begin + {The sequential feed pool - point to before the next sequential feed block} + ALastPtr := Pointer(PByte(APSmallBlockPool^.BlockType^.NextSequentialFeedBlockAddress) - 1); + end; +end; + +{-----------------Medium Block Management------------------} + +{Advances to the next medium block. Returns nil if the end of the medium block + pool has been reached} +function NextMediumBlock(APMediumBlock: Pointer): Pointer; +var + LBlockSize: NativeUInt; +begin + {Get the size of this block} + LBlockSize := PNativeUInt(PByte(APMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + {Advance the pointer} + Result := Pointer(PByte(APMediumBlock) + LBlockSize); + {Is the next block the end of medium pool marker?} + LBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + if LBlockSize = 0 then + Result := nil; +end; + +{Gets the first medium block in the medium block pool} +function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer; +begin + if (MediumSequentialFeedBytesLeft = 0) + or (UIntPtr(LastSequentiallyFedMediumBlock) < UIntPtr(APMediumBlockPoolHeader)) + or (UIntPtr(LastSequentiallyFedMediumBlock) > UIntPtr(APMediumBlockPoolHeader) + MediumBlockPoolSize) then + begin + Result := Pointer(PByte(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize); + end + else + begin + {Is the sequential feed pool empty?} + if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then + Result := LastSequentiallyFedMediumBlock + else + Result := nil; + end; +end; + + + +{$ifdef Use32BitAsm} + {$ifndef MediumBlocksLockedCriticalSection} + {$define UseOriginalFastMM4_LockMediumBlocksAsm} + {$endif} +{$endif} + +{$ifdef XE2AndUp} + {$define UseSystemAtomicIntrinsics} +{$endif} + + +{$ifdef DisablePauseAndSwitchToThread} +const + CpuFeaturePauseAndSwitch = False; +{$else} +{$ifdef AssumePauseAndSwitchToThreadAvailable} +const + CpuFeaturePauseAndSwitch = True; +{$else} +function CpuFeaturePauseAndSwitch: Boolean; {$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif} +begin + {$ifdef USE_CPUID} + Result := FastMMCpuFeatures and FastMMCpuFeaturePauseAndSwitch <> 0 + {$else} + Result := False; + {$endif} +end; +{$endif} +{$endif DisablePauseAndSwitchToThread} + + + +{Locks the medium blocks. Note that the 32-bit assembler version is assumed to + preserve all registers except eax.} + +{$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} + +function LockMediumBlocks({$ifdef UseReleaseStack}APointer: Pointer = nil; APDelayRelease: PBoolean = nil{$endif}): Boolean; // returns true if was contention + + {$ifdef MediumBlocksLockedCriticalSection} + {$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} + {$endif} + +{$ifdef UseReleaseStack} +var + LPReleaseStack: ^TLFStack; +{$endif} +begin + Result := False; + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + {$ifdef MediumBlocksLockedCriticalSection} + {$ifndef DisablePauseAndSwitchToThread} + if CpuFeaturePauseAndSwitch then + begin + if not AcquireLockByte(MediumBlocksLocked) then + begin + Result := True; + AcquireSpinLockByte(MediumBlocksLocked); + end; + end else + {$endif} + begin + EnterCriticalSection(MediumBlocksLockedCS); + end + {$else MediumBlocksLockedCriticalSection} + while not AcquireLockByte(MediumBlocksLocked) do + begin + Result := True; // had contention + {$ifdef UseReleaseStack} + if Assigned(APointer) then + begin + LPReleaseStack := @(MediumReleaseStack[GetStackSlot]); + if (not LPReleaseStack^.IsFull) and LPReleaseStack.Push(APointer) then + begin + APointer := nil; + APDelayRelease^ := True; + Exit; + end; + end; + {$endif} + {$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} + {$else} + Sleep(InitialSleepTime); + if AcquireLockByte(MediumBlocksLocked) then + Break; + Sleep(AdditionalSleepTime); + {$endif} + end; + {$ifdef UseReleaseStack} + if Assigned(APDelayRelease) then + APDelayRelease^ := False; + {$endif} + {$endif MediumBlocksLockedCriticalSection} + end; +end; + +{$else UseOriginalFastMM4_LockMediumBlocksAsm} + +{ This is the original "LockMediumBlocks" assembly implementation that uses a +loop of Sleep() or SwitchToThread() as opposing to an efficient approach of FastMM4-AVX. } + +procedure LockMediumBlocks; +asm +{ This implemenation will not be compiled into FastMM4-AVX unless you + undefine the MediumBlocksLockedCriticalSection. You may only need + this implementation if you would like to use the old locking mechanism of + the original FastMM4 } + + {Note: This routine is assumed to preserve all registers except eax for 32-bit Assembly} +@MediumBlockLockLoop: + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah // cmpxchg also uses AL as an implicit operand + je @DoneNoContention +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + db $F3, $90 // pause + {$ifdef UseSwitchToThread} + push ecx + push edx + call SwitchToThreadIfSupported + pop edx + pop ecx + {$endif} + {Try again} + jmp @MediumBlockLockLoop +{$else 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, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to grab the block type} + lock cmpxchg MediumBlocksLocked, ah // cmpxchg also uses AL as an implicit operand + je @DoneWithContention + {Couldn't lock the medium blocks - sleep and try again} + push ecx + push edx + push AdditionalSleepTime + call Sleep + pop edx + pop ecx + {Try again} + jmp @MediumBlockLockLoop +{$endif NeverSleepOnThreadContention} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DoneNoContention: + xor eax, eax + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DoneWithContention: + mov eax, 1 +@Done: +end; +{$endif UseOriginalFastMM4_LockMediumBlocksAsm} + +procedure UnlockMediumBlocks; + {$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} +begin + {$ifdef MediumBlocksLockedCriticalSection} + if CpuFeaturePauseAndSwitch then + begin + ReleaseLockByte(MediumBlocksLocked); + end else + begin + LeaveCriticalSection(MediumBlocksLockedCS); + end; + {$else} + ReleaseLockByte(MediumBlocksLocked); + {$endif} +end; + + + +{Removes a medium block from the circular linked list of free blocks. + Does not change any header flags. Medium blocks should be locked + before calling this procedure.} +procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); +{$ifndef ASMVersion} +var + LMask: Cardinal; + LShift: Byte; + LPreviousFreeBlock, + LNextFreeBlock: PMediumFreeBlock; + LBinNumber, + LBinGroupNumber: Cardinal; +begin + {Get the current previous and next blocks} + LNextFreeBlock := APMediumFreeBlock^.NextFreeBlock; + LPreviousFreeBlock := APMediumFreeBlock^.PreviousFreeBlock; + {Remove this block from the linked list} + LPreviousFreeBlock^.NextFreeBlock := LNextFreeBlock; + LNextFreeBlock^.PreviousFreeBlock := LPreviousFreeBlock; + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + if LPreviousFreeBlock = LNextFreeBlock then + begin + {Get the bin number for this block size} + LBinNumber := (UIntPtr(LNextFreeBlock) - UIntPtr(@MediumBlockBins)) shr MediumFreeBlockSizePowerOf2; + LBinGroupNumber := LBinNumber shr MediumBlockBinsPerGroupPowerOf2; + {Flag this bin as empty} + LShift := LBinNumber and (MediumBlockBinsPerGroup-1); + LMask := not (Cardinal(UnsignedBit) shl LShift); + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] and LMask; + {Is the group now entirely empty?} + if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then + begin + LMask := not (Cardinal(UnsignedBit) shl LBinGroupNumber); + + {Flag this group as empty} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap and LMask; + end; + end; +end; +{$else} +{$ifdef 32Bit} +assembler; +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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@Done: + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@BinIsNowEmpty: + {Get the bin number for this block size in ecx} + sub ecx, offset MediumBlockBins + mov edx, ecx + shr ecx, MediumFreeBlockSizePowerOf2 + {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 +@Exit: +end; +{$else} +assembler; +asm +{$ifdef AllowAsmNoframe} + .noframe +{$endif} + {On entry: rcx = APMediumFreeBlock} + mov rax, rcx + {Get the current previous and next blocks} + mov rcx, TMediumFreeBlock[rax].NextFreeBlock + mov rdx, TMediumFreeBlock[rax].PreviousFreeBlock + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + cmp rcx, rdx + {Remove this block from the linked list} + mov TMediumFreeBlock[rcx].PreviousFreeBlock, rdx + mov TMediumFreeBlock[rdx].NextFreeBlock, rcx + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + jne @Done + {Get the bin number for this block size in rcx} + lea r8, MediumBlockBins + sub rcx, r8 + mov edx, ecx + shr ecx, MediumFreeBlockSizePowerOf2 + {Get the group number in edx} + shr edx, 9 + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + lea r8, MediumBlockBinBitmaps + and dword ptr [r8 + rdx * 4], eax + jnz @Done + {Flag this group as empty} + mov eax, -2 + mov ecx, edx + rol eax, cl + and MediumBlockBinGroupBitmap, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@Done: +end; +{$endif} +{$endif} + +{Inserts a medium block into the appropriate medium block bin.} +procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal); +{$ifndef ASMVersion} +var + LMask: Cardinal; + LShift: Byte; + 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) shr MediumBlockGranularityPowerOf2; + 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 shr MediumBlockBinsPerGroupPowerOf2; + LShift := LBinNumber and (MediumBlockBinsPerGroup-1); // We need a separate variable LShift to avoid range check error + LMask := Cardinal(UnsignedBit) shl LShift; + {Flag this bin as used} + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] or LMask; + LMask := Cardinal(UnsignedBit) shl LBinGroupNumber; + {Flag the group as used} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap or LMask; + end; +end; +{$else} +{$ifdef 32Bit} +assembler; +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 + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 +@Exit: +end; +{$else} +assembler; +asm +{$ifdef AllowAsmNoframe} + .noframe +{$endif} + {On entry: rax = APMediumFreeBlock, edx = AMediumBlockSize} + mov rax, rcx + {Get the bin number for this block size. Get the bin that holds blocks of at + least this size.} + sub edx, MinimumMediumBlockSize + shr edx, 8 + {Validate the bin number} + sub edx, MediumBlockBinCount - 1 + sbb ecx, ecx + and edx, ecx + add edx, MediumBlockBinCount - 1 + mov r9, rdx + {Get the bin address in rcx} + lea rcx, MediumBlockBins + shl edx, 4 + add rcx, rdx + {Bins are LIFO, se we insert this block as the first free block in the bin} + mov rdx, TMediumFreeBlock[rcx].NextFreeBlock + {Was this bin empty?} + cmp rdx, rcx + mov TMediumFreeBlock[rax].PreviousFreeBlock, rcx + mov TMediumFreeBlock[rax].NextFreeBlock, rdx + mov TMediumFreeBlock[rdx].PreviousFreeBlock, rax + mov TMediumFreeBlock[rcx].NextFreeBlock, rax + {Was this bin empty?} + jne @Done + {Get the bin number in ecx} + mov rcx, r9 + {Get the group number in edx} + mov rdx, r9 + shr edx, 5 + {Flag this bin as not empty} + mov eax, 1 + shl eax, cl + lea r8, MediumBlockBinBitmaps + or dword ptr [r8 + rdx * 4], eax + {Flag the group as not empty} + mov eax, 1 + mov ecx, edx + shl eax, cl + or MediumBlockBinGroupBitmap, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@Done: +end; +{$endif} +{$endif} + +{Bins what remains in the current sequential feed medium block pool. Medium + blocks must be locked.} +procedure BinMediumSequentialFeedRemainder; +{$ifndef ASMVersion} +var + LSequentialFeedFreeSize, + LNextBlockSizeAndFlags: NativeUInt; + LPRemainderBlock, + LNextMediumBlock: Pointer; +begin + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize > 0 then + begin + {Get the block after the open space} + LNextMediumBlock := LastSequentiallyFedMediumBlock; + LNextBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^; + {Point to the remainder} + LPRemainderBlock := Pointer(PByte(LNextMediumBlock) - LSequentialFeedFreeSize); +{$ifndef FullDebugMode} + {Can the next block be combined with the remainder?} + if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + {Increase the size of this block} + Inc(LSequentialFeedFreeSize, LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask); + {Remove the next block as well} + if (LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask) >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LNextMediumBlock); + end + else + begin +{$endif} + {Set the "previous block is free" flag of the next block} + PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; +{$ifndef FullDebugMode} + end; +{$endif} + {Store the size of the block as well as the flags} + PNativeUInt(PByte(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag; + {Store the trailing size marker} + PNativeUInt(PByte(LPRemainderBlock) + LSequentialFeedFreeSize - BlockHeaderSize * 2)^ := LSequentialFeedFreeSize; +{$ifdef FullDebugMode} + {In full debug mode the sequential feed remainder will never be too small to + fit a full debug header.} + {Clear the user area of the block} + DebugFillMem(Pointer(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^, + LSequentialFeedFreeSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {We need to set a valid debug header and footer in the remainder} + PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := NativeUInt(LPRemainderBlock); + PNativeUInt(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(LPRemainderBlock); +{$endif} + {Bin this medium block} + if LSequentialFeedFreeSize >= MinimumMediumBlockSize then + begin + InsertMediumBlockIntoBin(LPRemainderBlock, LSequentialFeedFreeSize); + end; + end; +end; +{$else} +{$ifdef 32Bit} +assembler; +asm + cmp MediumSequentialFeedBytesLeft, 0 + jne @MustBinMedium + {Nothing to bin} + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], IsFreeBlockFlag + jnz @LastBlockFedIsFree + {Set the "previous block is free" flag in the last block fed} + or dword ptr [eax - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + {Get the remainder in edx} + mov edx, MediumSequentialFeedBytesLeft + {Point eax to the start of the remainder} + sub eax, edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], ecx + {Store the trailing size marker} + mov [eax + edx - BlockHeaderSize * 2], edx + {Bin this medium block} + cmp edx, MinimumMediumBlockSize + jnb InsertMediumBlockIntoBin + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@LastBlockFedIsFree: + {Drop the flags} + mov edx, DropMediumAndLargeFlagsMask + and edx, [eax - BlockHeaderSize] + {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 - BlockHeaderSize] + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@Done: +end; +{$else} +assembler; +asm + {Don't put ".noframe" here because this function calls other functions, e.g. + "InsertMediumBlockIntoBin", "RemoveMediumFreeBlock", etc. + According to the documentation at + http://docwiki.embarcadero.com/RADStudio/Tokyo/en/Assembly_Procedures_and_Functions + ".noframe: forcibly disables the generation of a stack frame as long as there + are no local variables declared and the parameter count <= 4. + Thus, ".noframe" can only be used for leaf functions. A leaf function is one + that does not call another function. That is one that is always at the bottom + of the call tree.} + {$ifdef AllowAsmParams} + .params 2 + {$endif} + xor eax, eax + cmp MediumSequentialFeedBytesLeft, eax + je @Done + {Get a pointer to the last sequentially allocated medium block} + mov rax, LastSequentiallyFedMediumBlock + {Is the block that was last fed sequentially free?} + test byte ptr [rax - BlockHeaderSize], IsFreeBlockFlag + jnz @LastBlockFedIsFree + {Set the "previous block is free" flag in the last block fed} + or qword ptr [rax - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + {Get the remainder in edx} + mov edx, MediumSequentialFeedBytesLeft + {Point eax to the start of the remainder} + sub rax, rdx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@BinTheRemainder: + {Status: rax = start of remainder, edx = size of remainder} + {Store the size of the block as well as the flags} + lea rcx, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rax - BlockHeaderSize], rcx + {Store the trailing size marker} + mov [rax + rdx - 2 * BlockHeaderSize], rdx + {Bin this medium block} + cmp edx, MinimumMediumBlockSize + jb @Done + mov rcx, rax + call InsertMediumBlockIntoBin + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@LastBlockFedIsFree: + {Drop the flags} + mov rdx, DropMediumAndLargeFlagsMask + and rdx, [rax - BlockHeaderSize] + {Free the last block fed} + cmp edx, MinimumMediumBlockSize + jb @DontRemoveLastFed + {Last fed block is free - remove it from its size bin} + mov rcx, rax + call RemoveMediumFreeBlock + {Re-read rax and rdx} + mov rax, LastSequentiallyFedMediumBlock + mov rdx, DropMediumAndLargeFlagsMask + and rdx, [rax - BlockHeaderSize] + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DontRemoveLastFed: + {Get the number of bytes left in ecx} + mov ecx, MediumSequentialFeedBytesLeft + {Point rax to the start of the remainder} + sub rax, rcx + {edx = total size of the remainder} + add edx, ecx + jmp @BinTheRemainder + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@Done: +end; +{$endif} +{$endif} + +{Allocates a new sequential feed medium block pool and immediately splits off a + block of the requested size. The block size must be a multiple of 16 and + medium blocks must be locked.} +function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer; +var + LOldFirstMediumBlockPool: PMediumBlockPoolHeader; + LNewPool: Pointer; +begin + {Bin the current sequential feed remainder} + BinMediumSequentialFeedRemainder; + {Allocate a new sequential feed block pool} + LNewPool := VirtualAlloc(nil, MediumBlockPoolSize, + MEM_COMMIT{$ifdef AlwaysAllocateTopDown} or MEM_TOP_DOWN{$endif}, PAGE_READWRITE); + if LNewPool <> nil then + begin + {Insert this block pool into the list of block pools} + LOldFirstMediumBlockPool := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + PMediumBlockPoolHeader(LNewPool)^.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := LNewPool; + PMediumBlockPoolHeader(LNewPool)^.NextMediumBlockPoolHeader := LOldFirstMediumBlockPool; + LOldFirstMediumBlockPool^.PreviousMediumBlockPoolHeader := LNewPool; + {Store the sequential feed pool trailer} + PNativeUInt(PByte(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag; + {Get the number of bytes still available} + MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize; + {Get the result} + Result := Pointer(PByte(LNewPool) + MediumBlockPoolSize - AFirstBlockSize); + LastSequentiallyFedMediumBlock := Result; + {Store the block header} + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag; + end + else + begin + {Out of memory} + MediumSequentialFeedBytesLeft := 0; + Result := nil; + end; +end; + +{-----------------Large Block Management------------------} + + +{Locks the large blocks} +function LockLargeBlocks({$ifdef UseReleaseStack}APointer: Pointer = nil; APDelayRelease: PBoolean = nil{$endif}): Boolean; // returns true if there was contention + +{$ifdef LargeBlocksLockedCriticalSection} +{$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} +{$endif} + + +{$ifdef UseReleaseStack} +var + LPReleaseStack: ^TLFStack; +{$endif} +begin + Result := False; + {Lock the large blocks} + +{$ifndef AssumeMultiThreaded} +{$ifdef FullDebugMode} + if not IsMultiThread then + begin + {The checks for IsMultiThread should be from outsize} + {$ifndef SystemRunError} + System.Error(reInvalidOp); + {$else} + System.RunError(reInvalidOp); + {$endif} + end; +{$endif} +{$endif} + +{$ifdef LargeBlocksLockedCriticalSection} + {$ifndef DisablePauseAndSwitchToThread} + if CpuFeaturePauseAndSwitch then + begin + if not AcquireLockByte(LargeBlocksLocked) then + begin + Result := True; + AcquireSpinLockByte(LargeBlocksLocked); + end; + end else + {$endif} + begin + EnterCriticalSection(LargeBlocksLockedCS); + end; +{$else LargeBlocksLockedCriticalSection} + while not AcquireLockByte(LargeBlocksLocked) do + begin + Result := True; +{$ifdef UseReleaseStack} + if Assigned(APointer) then + begin + LPReleaseStack := @LargeReleaseStack[GetStackSlot]; + if (not LPReleaseStack^.IsFull) and LPReleaseStack.Push(APointer) then + begin + APointer := nil; + APDelayRelease^ := True; + Exit; + end; + end; +{$endif} +{$ifdef NeverSleepOnThreadContention} +{$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; +{$endif} +{$else} + Sleep(InitialSleepTime); + if AcquireLockByte(LargeBlocksLocked) then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; +{$ifdef UseReleaseStack} + if Assigned(APDelayRelease) then + APDelayRelease^ := False; +{$endif} +{$endif LargeBlocksLockedCriticalSection} +end; + +procedure UnlockLargeBlocks; + {$ifndef DEBUG}{$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif}{$endif} +begin + {$ifdef LargeBlocksLockedCriticalSection} + if CpuFeaturePauseAndSwitch then + begin + ReleaseLockByte(LargeBlocksLocked); + end else + begin + LeaveCriticalSection(LargeBlocksLockedCS); + end; + {$else} + ReleaseLockByte(LargeBlocksLocked); + {$endif} +end; + + +{Allocates a Large block of at least ASize (actual size may be larger to + allow for alignment etc.). ASize must be the actual user requested size. This + procedure will pad it to the appropriate page boundary and also add the space + required by the header.} +function AllocateLargeBlock(ASize: NativeUInt {$ifdef LogLockContention}; var ADidSleep: Boolean{$endif}): Pointer; +var + LLargeUsedBlockSize: NativeUInt; + LOldFirstLargeBlock: PLargeBlockHeader; + {$ifndef AssumeMultiThreaded} + LLockLargeBlocksLocked: Boolean; + {$endif} +begin + {$ifndef AssumeMultiThreaded} + LLockLargeBlocksLocked := False; + {$endif} + {Pad the block size to include the header and granularity. We also add a + SizeOf(Pointer) overhead so a huge block size is a multiple of 16 bytes less + SizeOf(Pointer) (so we can use a single move function for reallocating all + block types)} + LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize) + and LargeBlockGranularityMask; + {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; + {$ifndef AssumeMultiThreaded} + if IsMultiThread then + {$endif} + begin + {$ifndef AssumeMultiThreaded} + LLockLargeBlocksLocked := True; + {$endif} + {$ifdef LogLockContention}ADidSleep:={$endif} + {Insert the large block into the linked list of large blocks} + LockLargeBlocks; + end; + LOldFirstLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + PLargeBlockHeader(Result)^.PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := Result; + PLargeBlockHeader(Result)^.NextLargeBlockHeader := LOldFirstLargeBlock; + LOldFirstLargeBlock^.PreviousLargeBlockHeader := Result; + {$ifndef AssumeMultiThreaded} + if LLockLargeBlocksLocked then + {$endif} + begin + {$ifndef AssumeMultiThreaded} + // LLockLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + {$endif} + UnlockLargeBlocks; + end; + {Add the size of the header} + Inc(PByte(Result), LargeBlockHeaderSize); +{$ifdef FullDebugMode} + {Since large blocks are never reused, the user area is not initialized to + the debug fill pattern, but the debug header and footer must be set.} + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); +{$endif} + end; +end; + +{Frees a large block, returning 0 on success, -1 otherwise} +function FreeLargeBlock(APointer: Pointer + {$ifdef UseReleaseStack}; ACleanupOperation: Boolean = False{$endif}): Integer; +var + LPointer: Pointer; + LPreviousLargeBlockHeader, + LNextLargeBlockHeader: PLargeBlockHeader; +{$ifndef POSIX} + LRemainingSize: NativeUInt; + LCurrentSegment: Pointer; + LMemInfo: TMemoryBasicInformation; +{$endif} +{$ifdef LogLockContention} + LDidSleep: Boolean; + LStackTrace: TStackTrace; +{$endif} +{$ifdef UseReleaseStack} + LDelayRelease: Boolean; + LPReleaseStack: ^TLFStack; +{$endif} +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked: Boolean; +{$endif} +begin + LPointer := APointer; +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := False; +{$endif} +{$ifdef ClearLargeBlocksBeforeReturningToOS} + FillChar(LPointer^, + (PLargeBlockHeader(PByte(LPointer) - LargeBlockHeaderSize).BlockSizeAndFlags + and DropMediumAndLargeFlagsMask) - LargeBlockHeaderSize, 0); +{$endif} + {When running a cleanup operation, large blocks are already locked} +{$ifdef UseReleaseStack} + if not ACleanupOperation then + begin +{$endif} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep :={$endif} + LockLargeBlocks({$ifdef UseReleaseStack}LPointer, @LDelayRelease{$endif}); + end; +{$ifdef UseReleaseStack} + if LDelayRelease then + begin + Result := 0; + Exit; + end; + {$ifdef LogLockContention} + end + else + LDidSleep := False; + {$else} + end; + {$endif} +{$endif} +{$ifdef LogLockContention} + if LDidSleep then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + LargeBlockCollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif} +{$ifdef UseReleaseStack} + repeat +{$endif} + {Point to the start of the large block} + LPointer := Pointer(PByte(LPointer) - LargeBlockHeaderSize); + {Get the previous and next large blocks} + LPreviousLargeBlockHeader := PLargeBlockHeader(LPointer)^.PreviousLargeBlockHeader; + LNextLargeBlockHeader := PLargeBlockHeader(LPointer)^.NextLargeBlockHeader; + {$ifndef POSIX} + {Is the large block segmented?} + if (PLargeBlockHeader(LPointer)^.BlockSizeAndFlags and LargeBlockIsSegmented) = 0 then + begin + {$endif} + {Single segment large block: Try to free it} + if VirtualFree(LPointer, 0, MEM_RELEASE) then + Result := 0 + else + Result := -1; + {$ifndef POSIX} + end + else + begin + {The large block is segmented - free all segments} + LCurrentSegment := LPointer; + LRemainingSize := PLargeBlockHeader(LPointer)^.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Result := 0; + while True do + begin + {Get the size of the current segment} + FillChar(LMemInfo, SizeOf(LMemInfo), 0); + VirtualQuery(LCurrentSegment, LMemInfo, SizeOf(LMemInfo)); + {Free the segment} + if not VirtualFree(LCurrentSegment, 0, MEM_RELEASE) then + begin + Result := -1; + Break; + end; + {Done?} + if NativeUInt(LMemInfo.RegionSize) >= LRemainingSize then + Break; + {Decrement the remaining size} + Dec(LRemainingSize, NativeUInt(LMemInfo.RegionSize)); + Inc(PByte(LCurrentSegment), NativeUInt(LMemInfo.RegionSize)); + end; + end; + {$endif} + {Success?} + if Result = 0 then + begin + {Remove the large block from the linked list} + LNextLargeBlockHeader^.PreviousLargeBlockHeader := LPreviousLargeBlockHeader; + LPreviousLargeBlockHeader^.NextLargeBlockHeader := LNextLargeBlockHeader; + end; +{$ifdef UseReleaseStack} + if (Result <> 0) or ACleanupOperation then + Break; + LPReleaseStack := @LargeReleaseStack[GetStackSlot]; + if LPReleaseStack^.IsEmpty or (not LPReleaseStack.Pop(LPointer)) then + Break; + {$ifdef ClearLargeBlocksBeforeReturningToOS} + FillChar(LPointer^, + (PLargeBlockHeader(PByte(LPointer) - LargeBlockHeaderSize).BlockSizeAndFlags + and DropMediumAndLargeFlagsMask) - LargeBlockHeaderSize, 0); + {$endif} + until False; +{$endif} +{$ifndef AssumeMultiThreaded} + if LLargeBlocksLocked then +{$endif} + begin + // LLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + {Unlock the large blocks} + UnlockLargeBlocks; + end; +end; + +{$ifndef FullDebugMode} +{Reallocates a large block to at least the requested size. Returns the new + pointer, or nil on error} +function ReallocateLargeBlock(APointer: Pointer; ANewSize: NativeUInt): Pointer; +var + LOldAvailableSize, + LBlockHeader, + LOldUserSize, + LMinimumUpsize, + LNewAllocSize: NativeUInt; +{$ifndef POSIX} + LNewSegmentSize: NativeUInt; + LNextSegmentPointer: Pointer; + LMemInfo: TMemoryBasicInformation; +{$endif} +begin + {Get the block header} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Large block - size is (16 + 4) less than the allocated size} + LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize); + {Is it an upsize or a downsize?} + if ANewSize > LOldAvailableSize then + begin + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Add 25% for large block upsizes} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if ANewSize < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := ANewSize; +{$ifndef POSIX} + {Can another large block segment be allocated directly after this segment, + thus negating the need to move the data?} + LNextSegmentPointer := Pointer(PByte(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask)); + FilLChar(LMemInfo, SizeOf(LMemInfo), 0); + 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 LargeBlockGranularityMask; + {Enough space to grow in place?} + if NativeUInt(LMemInfo.RegionSize) > (ANewSize - LOldAvailableSize) then + begin + {There is enough space after the block to extend it - determine by how + much} + LNewSegmentSize := (LNewAllocSize - LOldAvailableSize + LargeBlockGranularity - 1) and LargeBlockGranularityMask; + if LNewSegmentSize > LMemInfo.RegionSize then + LNewSegmentSize := LMemInfo.RegionSize; + {Attempy to reserve the address range (which will fail if another + thread has just reserved it) and commit it immediately afterwards.} + if (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_RESERVE, PAGE_READWRITE) <> nil) + and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then + begin + {Update the requested size} + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.BlockSizeAndFlags := + (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.BlockSizeAndFlags + LNewSegmentSize) + or LargeBlockIsSegmented; + {Success} + Result := APointer; + Exit; + end; + end; + end; +{$endif} + {Could not resize in place: Allocate the new block} + Result := FastGetMem(LNewAllocSize); + if Result <> nil then + begin + {If it's a large block - store the actual user requested size (it may + not be if the block that is being reallocated from was previously + downsized)} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + {The user allocated size is stored for large blocks} + LOldUserSize := PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.UserAllocatedSize; + {The number of bytes to move is the old user size.} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + MoveX32LPUniversal(APointer^, Result^, LOldUserSize); + {$else} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, LOldUserSize); + {$else} + MoveX8LP(APointer^, Result^, LOldUserSize); + {$endif} + {$endif} +{$else} + System.Move(APointer^, Result^, LOldUserSize); +{$endif} + {Free the old block} + FastFreeMem(APointer); + end; + end + else + begin + {It's a downsize: do we need to reallocate? Only if the new size is less + than half the old size} + if ANewSize >= (LOldAvailableSize shr 1) then + begin + {No need to reallocate} + Result := APointer; + {Update the requested size} + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + end + else + begin + {The block is less than half the old size, and the current size is + greater than the minimum block size allowing a downsize: reallocate} + Result := FastGetMem(ANewSize); + if Result <> nil then + begin + {Still a large block? -> Set the user size} + if ANewSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} +{$ifdef Align32Bytes} + MoveX32LPUniversal(APointer^, Result^, ANewSize); +{$else} +{$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, ANewSize); +{$else} + MoveX8LP(APointer^, Result^, ANewSize); +{$endif} +{$endif} +{$else} + System.Move(APointer^, Result^, ANewSize); +{$endif} + {Free the old block} + FastFreeMem(APointer); + end; + end; + end; +end; +{$endif} + +{---------------------Replacement Memory Manager Interface---------------------} + +{This function is only needed to cope with an error that happens at runtime +when using the "typed @ operator" compiler option. We are having just +one typecast in this function to avoid using typecasts throught the +entire FastMM4 module.} + +function NegCardinalMaskBit(A: Cardinal): Cardinal; +{$ifndef ASMVersion} +begin + Result := Cardinal(0-Int64(A)); +end; +{$else} +assembler; +asm +{$ifdef 32bit} + neg eax +{$else} + {$ifdef unix} + mov eax, edi + {$else} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + mov eax, ecx + {$endif} + neg eax +{$endif} +end; +{$endif} + +function NegByteMaskBit(A: Byte): Byte; +{$ifndef ASMVersion} +begin +{$ifdef Delphi4or5} + Result := Byte((0-ShortInt(A))); +{$else} + Result := Byte((0-System.Int8(A))); +{$endif} +end; +{$else} +assembler; +asm +{$ifdef 32bit} + neg al +{$else} + {$ifdef unix} + movzx eax, dil + {$else} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + movzx eax, cl + {$endif} + neg al +{$endif} +end; +{$endif ASMVersion} + +function NegNativeUIntMaskBit(A: NativeUInt): NativeUint; +{$ifndef ASMVersion} +begin + Result := NativeUInt(0-Int64(A)); +end; +{$else} +assembler; +asm +{$ifdef 32bit} + neg eax +{$else} + {$ifdef unix} + mov rax, rdi + {$else} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + mov rax, rcx + {$endif} + neg rax +{$endif} +end; +{$endif ASMVersion} + +{$ifdef DebugReleaseLockByte} +procedure SmallBlockUnlockError; +begin +{$ifndef SystemRunError} + System.Error(reInvalidOp); +{$else} + System.RunError(reInvalidOp); +{$endif} +end; +{$endif} + + +{$ifndef ASMVersion} +{$define NeedFindFirstSetBit} +{$endif} + +{$ifdef FastGetMemNeedPascalCode} +{$define NeedFindFirstSetBit} +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{$define NeedFindFirstSetBit} +{$endif} + + +{$ifdef NeedFindFirstSetBit} +{Gets the first set bit in the 32-bit number, returning the bit index} +function FindFirstSetBit(ACardinal: Cardinal): Cardinal; +{$ifndef ASMVersion} +var + LOffset : Integer; + LCardinal: Cardinal; +begin + LCardinal := ACardinal; + LOffset := 0; + if LCardinal <> 0 then + begin + while (LCardinal and 1) = 0 do + begin + Inc(LOffset); + LCardinal := LCardinal shr 1; + end; + end; + Result := LOffset; +end; +{$else ASMVersion} +assembler; +{$ifdef fpc64bit} nostackframe; {$endif} +asm +{$ifdef 64Bit} + {$ifndef unix} + {$ifdef AllowAsmNoframe} + .noframe + {$endif} + mov eax, ecx + {$else} + mov eax, edi + {$endif} +{$endif} + bsf eax, eax +end; +{$endif ASMVersion} +{$endif NeedFindFirstSetBit} + + + +{$ifndef AssumeMultiThreaded} +const + StateBitMultithreaded = 1; + StateBitSmallLocked = 2; + StateBitMediumLocked = 3; +{$endif} + + +{Replacement for SysGetMem} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$ifdef FastGetMemNeedPascalCode} + function FastGetMemPascal(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif fpc}{$endif XE2AndUp}{$ifdef FullDebugMode}{$ifdef LogLockContention}; var ACollector: PStaticCollector{$endif}{$endif}): Pointer; forward; + {$endif} + {$ifdef FastGetMemNeedAssemblerCode} + function FastGetMemAssembler(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif fpc}{$endif XE2AndUp}{$ifdef FullDebugMode}{$ifdef LogLockContention}; var ACollector: PStaticCollector{$endif}{$endif}): Pointer; forward; + {$endif} +{$endif} + +{$ifdef DEBUG} +procedure BadAlignmentOnGetMem; +begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} +end; +{$endif} + + + + +function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif fpc}{$endif XE2AndUp}{$ifdef FullDebugMode}{$ifdef LogLockContention}; var ACollector: PStaticCollector{$endif}{$endif}): Pointer; + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +assembler; +asm + test FastMMCpuFeatures, FastMMCpuFeaturePauseAndSwitch + jz @CallFastGetMemPascal + call FastGetMemAssembler + jmp @Finish +@CallFastGetMemPascal: + call FastGetMemPascal +@Finish: +end; +{$endif} + + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +function FastGetMemPascal(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif fpc}{$endif XE2AndUp}{$ifdef FullDebugMode}{$ifdef LogLockContention}; var ACollector: PStaticCollector{$endif}{$endif}): Pointer; +{$endif} + +{$ifdef FastGetMemNeedPascalCode} +var + LMediumBlock: PMediumFreeBlock; +{$ifndef FullDebugMode} + LNextFreeBlock, LSecondSplit: PMediumFreeBlock; +{$endif} + LNextMediumBlockHeader: PNativeUInt; + LBlockSize, LAvailableBlockSize: NativeUInt; +{$ifndef FullDebugMode} + LSecondSplitSize: NativeUInt; +{$endif} + LSequentialFeedFreeSize: NativeUInt; + LPSmallBlockType: PSmallBlockType; + LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader; + LNewFirstFreeBlock: Pointer; + LPMediumBin: PMediumFreeBlock; + LBinNumber: NativeUInt; +{$ifndef FullDebugMode} + LBinGroupsMasked: NativeUInt; +{$endif} + LBinGroupMasked, + LBinGroupNumber: NativeUInt; +{$ifdef LogLockContention} + LDidSleep: Boolean; +{$ifndef FullDebugMode} + ACollector: PStaticCollector; + LStackTrace: TStackTrace; +{$endif FullDebugMode} +{$endif LogLockContention} +{$ifdef UseReleaseStack} + LPReleaseStack: ^TLFStack; +{$endif} +{$ifdef SmallBlocksLockedCriticalSection} + LSmallBlockCriticalSectionIndex: NativeUInt; + LFailedToAcquireLock: Boolean; +{$endif} + LSmallBlockSizeInGranularUnits: NativeUInt; +{$ifndef AssumeMultiThreaded} + LWasMultiThread: Boolean; +{$endif} + LMediumBlocksLocked: Boolean; + LSmallBlockWithoutLock: Boolean; + LBlockTypeIndex, LBlockTypeOffset: NativeUInt; + LShift: Byte; + LMask: Cardinal; +begin + + LMediumBlocksLocked := False; + LSmallBlockWithoutLock := False; + +{$ifndef AssumeMultiThreaded} + LWasMultiThread := False; +{$endif} +{$ifdef LogLockContention} + ACollector := nil; +{$endif} +{$ifdef SmallBlocksLockedCriticalSection} + LSmallBlockCriticalSectionIndex := MaxInt; + LFailedToAcquireLock := False; +{$endif} + {Is it a small block? -> Take the header size into account when + determining the required block size} + if NativeUInt(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then + begin + {-------------------------Allocate a small block---------------------------} + {Get the block type from the size} + LSmallBlockSizeInGranularUnits := (NativeUInt(ASize) + (BlockHeaderSize - 1)) shr SmallBlockGranularityPowerOf2; + LBlockTypeIndex := + {$ifdef AllocSize2SmallBlockTypesPrecomputedOffsets} + AllocSz2SmlBlkTypOfsDivSclFctr[LSmallBlockSizeInGranularUnits] + {$else} + AllocSize2SmallBlockTypesIdx[LSmallBlockSizeInGranularUnits] + {$endif} + ; + LBlockTypeOffset := LBlockTypeIndex + {$ifdef AllocSize2SmallBlockTypesPrecomputedOffsets} + shl MaximumCpuScaleFactorPowerOf2 + {$else} + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shl SmallBlockTypeRecSizePowerOf2 + {$else} + * SmallBlockTypeRecSize + {$endif} + {$endif} + ; + LPSmallBlockType := PSmallBlockType(LBlockTypeOffset+UIntPtr(@SmallBlockTypes[0])); +{$ifdef UseReleaseStack} + LPReleaseStack := @LPSmallBlockType.ReleaseStack[GetStackSlot]; + if (not LPReleaseStack^.IsEmpty) and LPReleaseStack^.Pop(Result) then + Exit; +{$endif} + {Lock the block type} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + {$ifndef AssumeMultiThreaded} + LWasMultiThread := True; + {$endif} + while True do + begin + {Try to lock the small block type (0)} + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + + {Try the next block type (+1)} + Inc(PByte(LPSmallBlockType), SmallBlockTypeRecSize); + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + + {Try up to two sizes past the requested size (+2)} + Inc(PByte(LPSmallBlockType), SmallBlockTypeRecSize); + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + + {All three sizes locked - give up and sleep (revert pointer (-2))} + Dec(PByte(LPSmallBlockType), 2 * SmallBlockTypeRecSize); + + {Try to once again, last time to lock the small block type (0)} + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + +{$ifdef SmallBlocksLockedCriticalSection} + LFailedToAcquireLock := True; + Break; +{$else} + {$ifdef LogLockContention} + ACollector := @LPSmallBlockType.BlockCollector; + {$endif} + {$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} + {$else} + {Both this block type and the next is in use: sleep} + Sleep(InitialSleepTime); + {Try to acquire the lock again} + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + {Sleep longer} + Sleep(AdditionalSleepTime); + {$endif} +{$endif} + end; + +{$ifdef SmallBlocksLockedCriticalSection} + {$ifndef DisablePauseAndSwitchToThread} + if CpuFeaturePauseAndSwitch then + begin + if LFailedToAcquireLock then + begin + AcquireSpinLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end; + end else + {$endif} + begin + LSmallBlockCriticalSectionIndex := (NativeUint(LPSmallBlockType)-NativeUint(@SmallBlockTypes)) + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shr SmallBlockTypeRecSizePowerOf2 + {$else} + div SmallBlockTypeRecSize + {$endif} + ; + EnterCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + if LFailedToAcquireLock then + begin + {Try the lock again} + if not AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + begin + LSmallBlockWithoutLock := True; + end; + end; + end; +{$endif} + + end; + {Get the first pool with free blocks} + LPSmallBlockPool := LPSmallBlockType^.NextPartiallyFreePool; + {Is the pool valid?} + if UIntPtr(LPSmallBlockPool) <> UIntPtr(LPSmallBlockType) then + begin + {Get the first free offset} + Result := LPSmallBlockPool^.FirstFreeBlock; + {Get the new first free block} + LNewFirstFreeBlock := PPointer(PByte(Result) - BlockHeaderSize)^; +{$ifdef CheckHeapForCorruption} + {The block should be free} + if (NativeUInt(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} +{$endif CheckHeapForCorruption} + LNewFirstFreeBlock := Pointer(UIntPtr(LNewFirstFreeBlock) and DropSmallFlagsMask); + {Increment the number of used blocks} + Inc(LPSmallBlockPool^.BlocksInUse); + {Set the new first free block} + LPSmallBlockPool^.FirstFreeBlock := LNewFirstFreeBlock; + {Is the pool now full?} + if LNewFirstFreeBlock = nil then + begin + {Pool is full - remove it from the partially free list} + LPNewFirstPool := LPSmallBlockPool^.NextPartiallyFreePool; + LPSmallBlockType^.NextPartiallyFreePool := LPNewFirstPool; + LPNewFirstPool^.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); + end; + end + else + begin + {Try to feed a small block sequentially} + Result := LPSmallBlockType^.NextSequentialFeedBlockAddress; + {Can another block fit?} + if UIntPtr(Result) <= UIntPtr(LPSmallBlockType^.MaxSequentialFeedBlockAddress) then + begin + {Get the sequential feed block pool} + LPSmallBlockPool := LPSmallBlockType^.CurrentSequentialFeedPool; + {Increment the number of used blocks in the sequential feed pool} + Inc(LPSmallBlockPool^.BlocksInUse); + {Store the next sequential feed block address} + LPSmallBlockType^.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType^.BlockSize); + end + else + begin + {Need to allocate a pool: Lock the medium blocks} + {$ifndef AssumeMultiThreaded} + if IsMultiThread then + {$endif} + begin + {$ifndef AssumeMultiThreaded} + LWasMultiThread := True; + {$endif} + LMediumBlocksLocked := True; + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + end; +{$ifdef LogLockContention} + if LDidSleep then + ACollector := @MediumBlockCollector; +{$endif} +{$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 shl MediumBlockBinsPerGroupPowerOf2); + 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 + LShift := LBinNumber and (MediumBlockBinsPerGroup-1); + LMask := not (Cardinal(UnsignedBit) shl LShift); + {Flag this bin as empty} + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] and LMask; + {Is the group now entirely empty?} + if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then + begin + LMask := not (Cardinal(UnsignedBit) shl LBinGroupNumber); + {Flag this group as empty} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap and LMask; + end; + end; + {Get the size of the available medium block} + LBlockSize := PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + {$ifdef CheckHeapForCorruption} + {Check that this block is actually free and the next and previous blocks + are both in use.} + if ((PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) + or ((PNativeUInt(PByte(LMediumBlock) + (PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) + then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + {$endif} + {Should the block be split?} + if LBlockSize >= MaximumSmallBlockPoolSize then + begin + {Get the size of the second split} + LSecondSplitSize := LBlockSize - LPSmallBlockType^.OptimalBlockPoolSize; + {Adjust the block size} + LBlockSize := LPSmallBlockType^.OptimalBlockPoolSize; + {Split the block in two} + LSecondSplit := PMediumFreeBlock(PByte(LMediumBlock) + LBlockSize); + PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split as the second last dword/qword} + PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Put the remainder in a bin (it will be big enough)} + InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); + end + else + begin + {Mark this block as used in the block following it} + LNextMediumBlockHeader := PNativeUInt(PByte(LMediumBlock) + LBlockSize - BlockHeaderSize); + LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag); + end; + end + else +{$endif} + begin + {Check the sequential feed medium block pool for space} + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize >= LPSmallBlockType^.MinimumBlockPoolSize then + begin + {Enough sequential feed space: Will the remainder be usable?} + if LSequentialFeedFreeSize >= (LPSmallBlockType^.OptimalBlockPoolSize + MinimumMediumBlockSize) then + begin + LBlockSize := LPSmallBlockType^.OptimalBlockPoolSize; + end + else + LBlockSize := LSequentialFeedFreeSize; + {Get the block} + LMediumBlock := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize); + {Update the sequential feed parameters} + LastSequentiallyFedMediumBlock := LMediumBlock; + MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; + end + else + begin + {Need to allocate a new sequential feed medium block pool: use the + optimal size for this small block pool} + LBlockSize := LPSmallBlockType^.OptimalBlockPoolSize; + {Allocate the medium block pool} + LMediumBlock := AllocNewSequentialFeedMediumPool(LBlockSize); + if LMediumBlock = nil then + begin + {Out of memory} + {$ifndef AssumeMultiThreaded} + if LWasMultiThread then + {$endif} + begin + {Unlock the medium blocks} + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + {Unlock the block type} + if not LSmallBlockWithoutLock then + begin + ReleaseLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end else + begin + LSmallBlockWithoutLock := False; + end; + {$ifdef SmallBlocksLockedCriticalSection} + if LSmallBlockCriticalSectionIndex <> NativeUInt(MaxInt) then + begin + LeaveCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + LSmallBlockCriticalSectionIndex := NativeUInt(MaxInt); + end; + {$endif} + end; + {Failed} + Result := nil; + {done} + Exit; + end; + end; + end; + {Mark this block as in use} + {Set the size and flags for this block} + PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag; + {Unlock medium blocks} + {$ifndef AssumeMultiThreaded} + if LWasMultiThread then + {$endif} + begin + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + end; + {Set up the block pool} + LPSmallBlockPool := PSmallBlockPoolHeader(LMediumBlock); + LPSmallBlockPool^.BlockType := LPSmallBlockType; + LPSmallBlockPool^.FirstFreeBlock := nil; + LPSmallBlockPool^.BlocksInUse := 1; + {Set it up for sequential block serving} + LPSmallBlockType^.CurrentSequentialFeedPool := LPSmallBlockPool; + Result := Pointer(PByte(LPSmallBlockPool) + SmallBlockPoolHeaderSize); + LPSmallBlockType^.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType^.BlockSize); + LPSmallBlockType^.MaxSequentialFeedBlockAddress := Pointer(PByte(LPSmallBlockPool) + LBlockSize - LPSmallBlockType^.BlockSize); + end; +{$ifdef FullDebugMode} + {Clear the user area of the block} + DebugFillMem(Pointer(PByte(Result) + (SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt)))^, + LPSmallBlockType^.BlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {Block was fed sequentially - we need to set a valid debug header. Use + the block address.} + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); +{$endif} + end; + {Set the block header} + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := UIntPtr(LPSmallBlockPool); + {$ifndef AssumeMultiThreaded} + if LWasMultiThread then + {$endif} + begin + {Unlock the block type} + if not LSmallBlockWithoutLock then + begin + ReleaseLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end else + begin + LSmallBlockWithoutLock := False; + end; + {$ifdef SmallBlocksLockedCriticalSection} + if LSmallBlockCriticalSectionIndex <> NativeUInt(MaxInt) then + begin + LeaveCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + LSmallBlockCriticalSectionIndex := NativeUInt(MaxInt); + end; + {$endif} + end; + end + else + begin + {Medium block or Large block?} + if NativeUInt(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then + begin + {------------------------Allocate a medium block--------------------------} + {Get the block size and bin number for this block size. Block sizes are + rounded up to the next bin size.} + LBlockSize := ((NativeUInt(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset)) + and MediumBlockGranularityMask) + MediumBlockSizeOffset; + {Get the bin number} + LBinNumber := (LBlockSize - MinimumMediumBlockSize) shr MediumBlockGranularityPowerOf2; + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LWasMultithread := True; +{$endif} + LMediumBlocksLocked := True; + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + {$ifdef LogLockContention} + if LDidSleep then + begin + ACollector := @MediumBlockCollector; + end; + {$endif} + end; + + {Calculate the bin group} + LBinGroupNumber := LBinNumber shr MediumBlockBinsPerGroupPowerOf2; + LShift := LBinNumber and (MediumBlockBinsPerGroup-1); + {Is there a suitable block inside this group?} + LBinGroupMasked := MediumBlockBinBitmaps[LBinGroupNumber] and NegCardinalMaskBit(Cardinal(UnsignedBit) shl LShift); + if LBinGroupMasked <> 0 then + begin + {Get the actual bin number} + LBinNumber := FindFirstSetBit(LBinGroupMasked) + (LBinGroupNumber shl MediumBlockBinsPerGroupPowerOf2); + end + else + begin +{$ifndef FullDebugMode} + {Try all groups greater than this group} + LBinGroupsMasked := MediumBlockBinGroupBitmap and NegNativeUIntMaskBit(NativeUInt(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 shl MediumBlockBinsPerGroupPowerOf2); + end + else + begin +{$endif} + {There are no bins with a suitable block: Sequentially feed the required block} + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize >= LBlockSize then + begin +{$ifdef FullDebugMode} + {In full debug mode a medium block must have enough bytes to fit + all the debug info, so we must make sure there are no tiny medium + blocks at the start of the pool.} + if LSequentialFeedFreeSize - LBlockSize < (FullDebugBlockOverhead + BlockHeaderSize) then + LBlockSize := LSequentialFeedFreeSize; +{$endif} + {Block can be fed sequentially} + Result := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize); + {Store the last sequentially fed block} + LastSequentiallyFedMediumBlock := Result; + {Store the remaining bytes} + MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; + {Set the flags for the block} + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; + end + else + begin + {Need to allocate a new sequential feed block} + Result := AllocNewSequentialFeedMediumPool(LBlockSize); + end; +{$ifdef FullDebugMode} + {Block was fed sequentially - we need to set a valid debug header} + if Result <> nil then + begin + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); + {Clear the user area of the block} + DebugFillMem(Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^, + LBlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + end; +{$endif} + {Done} + {$ifndef AssumeMultiThreaded} + if LWasMultithread then + {$endif} + begin + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + end; +{$ifdef LogLockContention} +{$ifndef FullDebugMode} + if Assigned(ACollector) then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + ACollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif} +{$endif} + Exit; +{$ifndef FullDebugMode} + end; +{$endif} + end; + {If we get here we have a valid LBinGroupNumber and LBinNumber: + Use the first block in the bin, splitting it if necessary} + {Get a pointer to the bin} + LPMediumBin := @(MediumBlockBins[LBinNumber]); + {Get the result} + Result := LPMediumBin^.NextFreeBlock; +{$ifdef CheckHeapForCorruption} + {Check that this block is actually free and the next and previous blocks + are both in use (except in full debug mode).} + if ((PNativeUInt(PByte(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag)) + {$ifndef FullDebugMode} + or ((PNativeUInt(PByte(Result) + (PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag)) + {$endif} + then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +{$endif CheckHeapForCorruption} + {Remove the block from the bin containing it} + RemoveMediumFreeBlock(Result); + {Get the block size} + LAvailableBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; +{$ifndef FullDebugMode} + {Is it an exact fit or not?} + LSecondSplitSize := LAvailableBlockSize - LBlockSize; + if LSecondSplitSize <> 0 then + begin + {Split the block in two} + LSecondSplit := PMediumFreeBlock(PByte(Result) + LBlockSize); + {Set the size of the second split} + PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split} + PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Put the remainder in a bin if it is big enough} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); + end + else + begin +{$else} + {In full debug mode blocks are never split or coalesced} + LBlockSize := LAvailableBlockSize; +{$endif} + {Mark this block as used in the block following it} + LNextMediumBlockHeader := Pointer(PByte(Result) + LBlockSize - BlockHeaderSize); +{$ifndef FullDebugMode} + {$ifdef CheckHeapForCorruption} + {The next block must be in use} + if (LNextMediumBlockHeader^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag) then + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + {$endif} +{$endif} + LNextMediumBlockHeader^ := + LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag); +{$ifndef FullDebugMode} + end; + {Set the size and flags for this block} + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; +{$else} + {In full debug mode blocks are never split or coalesced} + Dec(PNativeUInt(PByte(Result) - BlockHeaderSize)^, IsFreeBlockFlag); +{$endif} + {$ifndef AssumeMultiThreaded} + if LWasMultithread then + {$endif} + begin + if LMediumBlocksLocked then + begin + {Unlock the medium blocks} + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + end; + end + else + begin + {Allocate a Large block} + if ASize > 0 then + begin + Result := AllocateLargeBlock(ASize {$ifdef LogLockContention}, LDidSleep{$endif}); +{$ifdef LogLockContention} + if LDidSleep then + ACollector := @LargeBlockCollector; +{$endif} + end + else + Result := nil; + end; + end; +{$ifdef LogLockContention} +{$ifndef FullDebugMode} + if Assigned(ACollector) then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + ACollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif} +{$endif} +end; +{$endif FastGetMemNeedPascalCode} + +{$ifdef FastGetMemNeedAssemblerCode} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + function FastGetMemAssembler(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif fpc}{$endif XE2AndUp}{$ifdef FullDebugMode}{$ifdef LogLockContention}; var ACollector: PStaticCollector{$endif}{$endif}): Pointer; +{$endif} + +{$ifdef 32Bit} +assembler; +asm + {On entry: + eax = ASize} + +{EBP is not used at all in the assembly routine FastGetMem - use it for the FastMM flags, +like IsMultithreaded or MediumBlocksLocked} + +{$ifndef AssumeMultiThreaded} + push ebp {Save ebp} +{$endif} + push ebx {Save ebx} + +{$ifndef AssumeMultiThreaded} + xor ebp, ebp + + {Branchless operations to avoid misprediction} + cmp byte ptr [IsMultiThread], 0 + setnz bl + movzx ebx, bl + shl ebx, StateBitMultithreaded + or ebp, ebx +{$endif} + + {Since most allocations are for small blocks, determine the small block type + index so long} + lea edx, [eax + BlockHeaderSize - 1] + {Divide edx by SmallBlockGranularity which is always power of 2} + shr edx, SmallBlockGranularityPowerOf2 + {Is it a small block?} + cmp eax, (MaximumSmallBlockSize - BlockHeaderSize) + {Is it a small block?} + ja @NotASmallBlock + {Get the small block type in ebx} + movzx eax, byte ptr [AllocSz2SmlBlkTypOfsDivSclFctr + edx] + lea ebx, [SmallBlockTypes + eax * MaximumCpuScaleFactor] + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMultithreaded) + jnz @LockSmallBlockType {test+jnz invoke macro-op fusion} + jmp @AfterLock +{$else} + jmp @LockSmallBlockType +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotLockOnSmallBlockType: + {$ifdef SmallBlocksLockedCriticalSection}{$ifdef DebugAcquireLockByte} + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + {$endif}{$endif} + +{$ifndef AssumeMultiThreaded} + or ebp, (UnsignedBit shl StateBitSmallLocked) +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@AfterLock: + {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 - BlockHeaderSize] + {Set the new first free block} + mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx + {Set the block header} + mov [eax - BlockHeaderSize], edx + {Is the chunk now full?} + jz @RemoveSmallPool + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@UnlockSmallBlockAndExit: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitSmallLocked) + jz @Exit +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} + +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteAvailable + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + mov [eax - BlockHeaderSize], edx + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + jmp @UnlockSmallBlockAndExit + +{===== START OF SMALL BLOCK LOCKING CODE; 32-BIT FASTGETMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockType: + +{$ifdef SmallBlocksLockedCriticalSection} + mov eax, cLockByteLocked + mov edx, Type(TSmallBlockType) + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @FirstBlockLocked + {$else} + mov al, TSmallBlockType([ebx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @FirstBlockLocked + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@FirstBlockLocked: + {Try the next size} + add ebx, edx + {$ifndef DebugAcquireLockByte} + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @SecondBlockLocked + {$else} + mov al, TSmallBlockType([ebx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @SecondBlockLocked + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@SecondBlockLocked: + {Try the next size (up to two sizes larger)} + add ebx, edx + {$ifndef DebugAcquireLockByte} + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @ThirdBlockLocked + {$else} + mov al, TSmallBlockType([ebx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @ThirdBlockLocked + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@ThirdBlockLocked: + {Block type and two sizes larger are all locked - give up and sleep} + sub ebx, edx + sub ebx, edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockTypeLoop: + mov edx, cSpinWaitLoopCount + mov eax, cLockByteLocked + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + {$else} + mov al, TSmallBlockType([ebx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @NormalLoadLoop + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + je @DidntLock + {Congratulations! We've got the lock!} + jmp @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@SwitchToThread: + push ebx + push ecx + push esi + push edi + push ebp + call SwitchToThreadIfSupported + pop ebp + pop edi + pop esi + pop ecx + pop ebx + jmp @LockSmallBlockTypeLoop + +{$else !SmallBlocksLockedCriticalSection} + +{ The 32-bit implemenation from the original FastMM4 that employs a loop of Sleep() or SwitchToThread(). +By default, it will not be compiled into FastMM4-AVX which uses more efficient approach.} +@LockSmallBlockTypeLoop: + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + mov edx, eax + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType + {Try the next size} + add ebx, Type(TSmallBlockType) + mov eax, edx + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size (up to two sizes larger)} + add ebx, Type(TSmallBlockType) + mov eax, edx + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Block type and two sizes larger are all locked - give up and sleep} + sub ebx, 2 * Type(TSmallBlockType) +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + db $F3, $90 // pause + {$ifdef UseSwitchToThread} + call SwitchToThreadIfSupported + {$endif} + {Try again} + jmp @LockSmallBlockTypeLoop +{$else NeverSleepOnThreadContention} + {Couldn't grab the block type - sleep and try again} + push edx {just save edx} + push InitialSleepTime {argument} + call Sleep + pop eax {restore existing edx value straight into eax} + {Try again} + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + push AdditionalSleepTime + call Sleep + {Try again} + jmp @LockSmallBlockTypeLoop +{$endif NeverSleepOnThreadContention} +{$endif !SmallBlocksLockedCriticalSection} + +{===== END OF SMALL BLOCK LOCKING CODE; 32-BIT FASTGETMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@AllocateSmallBlockPool: + {save additional registers} + push esi + push edi + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLockedForPool +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} push ecx; push edx {$endif} + call LockMediumBlocks + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} pop edx; pop ecx {$endif} +{$else} + push edx + call AcquireSpinLockMediumBlocks + pop edx +{$endif} +{$ifndef AssumeMultiThreaded} + or ebp, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLockedForPool: + {Are there any available blocks of a suitable size?} + movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap + and esi, MediumBlockBinGroupBitmap + jz @NoSuitableMediumBlocks + {Get the bin group number with free blocks in eax} + bsf eax, esi + {Get the bin number in ecx} + lea esi, [eax * 8] + mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4] + bsf ecx, ecx + lea ecx, [ecx + esi * 4] + {Get a pointer to the bin in edi} + lea edi, [MediumBlockBins + ecx * 8] + {Get the free block in esi} + mov esi, TMediumFreeBlock[edi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov edx, TMediumFreeBlock[esi].NextFreeBlock + mov TMediumFreeBlock[edi].NextFreeBlock, edx + mov TMediumFreeBlock[edx].PreviousFreeBlock, edi + {Is this bin now empty?} + cmp edi, edx + jne @MediumBinNotEmpty + {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type} + {Flag this bin as empty} + mov edx, -2 + rol edx, cl + and dword ptr [MediumBlockBinBitmaps + eax * 4], edx + jnz @MediumBinNotEmpty + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], ecx + {Store the size of the second split as the second last dword} + mov [eax + edx - BlockHeaderSize * 2], edx + {Put the remainder in a bin (it will be big enough)} + call InsertMediumBlockIntoBin + jmp @GotMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotMuchSpace: + sub esi, edi + {Update the sequential feed parameters} + sub MediumSequentialFeedBytesLeft, edi + mov LastSequentiallyFedMediumBlock, esi + {Get the block pointer} + jmp @GotMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlMedBlksAftrAllocNewSeqFd +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontUnlMedBlksAftrAllocNewSeqFd: + mov eax, esi + pop edi + pop esi + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], ecx +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlMedBlksAftrGotMedBlk +{$endif} + {Unlock medium blocks} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {it destroys eax, ecx and edx, but we don't need them} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontUnlMedBlksAftrGotMedBlk: + {Set up the block pool} + xor eax, eax + 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 + {Set the small block header} + mov [eax - BlockHeaderSize], esi + {Restore registers} + pop edi + pop esi + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +{-------------------Medium block allocation-------------------} +@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, MediumBlockGranularityMask + add ebx, MediumBlockSizeOffset + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLocked +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} push ecx; push edx {$endif} + call LockMediumBlocks + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} pop edx; pop ecx {$endif} +{$else} + push edx + call AcquireSpinLockMediumBlocks + pop edx +{$endif} +{$ifndef AssumeMultiThreaded} + or ebp, (UnsignedBit shl StateBitMediumLocked) +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLocked: + {Get the bin number in ecx and the group number in edx} + lea edx, [ebx - MinimumMediumBlockSize] + mov ecx, edx + shr edx, 8 + 5 + shr ecx, 8 + {Is there a suitable block inside this group?} + mov eax, -1 + shl eax, cl + and eax, dword ptr [MediumBlockBinBitmaps + edx * 4] + jz @GroupIsEmpty + {Get the actual bin number} + and ecx, -MediumBlockBinsPerGroup + bsf eax, eax + or ecx, eax + jmp @GotBinAndGroup + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GroupIsEmpty: + {Try all groups greater than this group} + mov eax, -2 + mov ecx, edx + shl eax, cl + and eax, MediumBlockBinGroupBitmap + jz @TrySequentialFeedMedium + {There is a suitable group with space: get the bin number} + bsf edx, eax + {Get the bin in the group with free blocks} + mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4] + bsf ecx, eax + mov eax, edx + shl eax, 5 + or ecx, eax + jmp @GotBinAndGroup + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], ebx + jmp @MediumBlockGetDone + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@AllocateNewSequentialFeedForMedium: + mov eax, ebx + call AllocNewSequentialFeedMediumPool + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlockGetDone: +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @Exit +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + mov ebx, eax {save eax} + call UnlockMediumBlocks {it also destroys ecx and edx, but we no longer need them} + mov eax, ebx {restore eax} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBinNotEmptyForMedium: + {esi = free block, ebx = block size} + {Get the size of the available medium block in edi} + mov edi, DropMediumAndLargeFlagsMask + and edi, [esi - BlockHeaderSize] + {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 - BlockHeaderSize], ecx + {Store the size of the second split as the second last dword} + mov [eax + edx - BlockHeaderSize * 2], edx + {Put the remainder in a bin} + cmp edx, MinimumMediumBlockSize + jb @GotMediumBlockForMedium + call InsertMediumBlockIntoBin + jmp @GotMediumBlockForMedium + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@UseWholeBlockForMedium: + {Mark this block as used in the block following it} + and byte ptr [esi + edi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotMediumBlockForMedium: + {Set the size and flags for this block} + lea ecx, [ebx + IsMediumBlockFlag] + mov [esi - BlockHeaderSize], ecx +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlMedBlkAftrGotMedBlkForMedium +{$endif} + {Unlock medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {it also destroys ecx and edx, but we no longer need them} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@DontUnlMedBlkAftrGotMedBlkForMedium: + mov eax, esi + pop edi + pop esi + jmp @Exit +{-------------------Large block allocation-------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} + +@IsALargeBlockRequest: + test eax, eax + js @DontAllocateLargeBlock + pop ebx + +{$ifndef AssumeMultiThreaded} + pop ebp +{$endif} + call AllocateLargeBlock + jmp @Finish + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@DontAllocateLargeBlock: + xor eax, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@Exit: + pop ebx +{$ifndef AssumeMultiThreaded} + pop ebp +{$endif} +@Finish: +{$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMemC + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMemC: +{$endif} +end; +{$else} +{64-bit BASM implementation} +assembler; +asm + {On entry: + rcx = ASize} + + {Do not put ".noframe" here, for the reasons given at the comment + in the "BinMediumSequentialFeedRemainder" function at the start of the + 64-bit assembler code} + + {$ifdef AllowAsmParams} + .params 2 + .pushnv rbx + .pushnv rsi + .pushnv rdi + {$ifndef AssumeMultiThreaded} + .pushnv r12 + {$endif} + {$else} + push rbx + push rsi + push rdi + {$ifndef AssumeMultiThreaded} + push r12 + {$endif} + {$endif} + + {$ifndef AssumeMultiThreaded} + xor r12, r12 + {Get the IsMultiThread variable so long} + lea rsi, [IsMultiThread] + movzx esi, byte ptr [rsi] {this also clears highest bits of the rsi register} + test esi, esi + setnz sil + shl esi, StateBitMultithreaded + or r12, rsi +{$endif} + + {Since most allocations are for small blocks, determine the small block type + index so long. + Because the argument is a 64-bit value, we should operate 64-bit registers here } + lea rdx, [rcx + BlockHeaderSize - 1] + {Divide rdx by SmallBlockGranularity which is always power of 2} + shr rdx, SmallBlockGranularityPowerOf2 + + {Preload the addresses of some small block structures} + lea r8, AllocSize2SmallBlockTypesIdx + lea rbx, SmallBlockTypes + {Is it a small block?} + cmp rcx, (MaximumSmallBlockSize - BlockHeaderSize) + ja @NotASmallBlock + {Get the small block type pointer in rbx} + movzx ecx, byte ptr [r8 + rdx] + {The offset in the array wan't be bigger than 2^32 anyway, but an ecx instruction takes one byte less than the rcx one} + shl ecx, SmallBlockTypeRecSizePowerOf2 + add rbx, rcx + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMultithreaded) + jnz @LockSmallBlockType + jmp @AfterLockOnSmallBlockType +{$else} + jmp @LockSmallBlockType +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotLockOnSmallBlockType: + {$ifdef SmallBlocksLockedCriticalSection}{$ifdef DebugAcquireLockByte} + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + {$endif}{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitSmallLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@AfterLockOnSmallBlockType: + + {Find the next free block: Get the first pool with free blocks in rdx} + mov rdx, TSmallBlockType[rbx].NextPartiallyFreePool + {Get the first free block (or the next sequential feed address if rdx = rbx)} + mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock + {Get the drop flags mask in rcx so long} + mov rcx, DropSmallFlagsMask + {Is there a pool with free blocks?} + cmp rdx, rbx + je @TrySmallSequentialFeed + {Increment the number of used blocks} + add TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Get the new first free block} + and rcx, [rax - BlockHeaderSize] + {Set the new first free block} + mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx + {Set the block header} + mov [rax - BlockHeaderSize], rdx + {Is the chunk now full?} + jz @RemoveSmallPool + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@UnlockSmallBlockAndExit: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitSmallLocked) + jz @Done +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteAvailable + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@TrySmallSequentialFeed: + {Try to feed a small block sequentially: Get the sequential feed block pool} + mov rdx, TSmallBlockType[rbx].CurrentSequentialFeedPool + {Get the next sequential feed address so long} + movzx ecx, TSmallBlockType[rbx].BlockSize + add rcx, rax + {Can another block fit?} + cmp rax, TSmallBlockType[rbx].MaxSequentialFeedBlockAddress + ja @AllocateSmallBlockPool + {Increment the number of used blocks in the sequential feed pool} + add TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Store the next sequential feed block address} + mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rcx + {Set the block header} + mov [rax - BlockHeaderSize], rdx + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@RemoveSmallPool: + {Pool is full - remove it from the partially free list} + mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rbx + mov TSmallBlockType[rbx].NextPartiallyFreePool, rcx + jmp @UnlockSmallBlockAndExit + +{===== START OF SMALL BLOCK LOCKING CODE; 64-BIT FASTGETMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} + +@LockSmallBlockType: + +{$ifdef SmallBlocksLockedCriticalSection} + mov eax, cLockByteLocked + mov edx, Type(TSmallBlockType) +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @FirstBlockLocked + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@FirstBlockLocked: + {Try the next size} + add rbx, rdx + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @SecondBlockLocked + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@SecondBlockLocked: + {Try the next size (up to two sizes larger)} + add rbx, rdx + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @ThirdBlockLocked + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@ThirdBlockLocked: + {Block type and two sizes larger are all locked - give up and sleep} + sub rbx, rdx + sub rbx, rdx + push rcx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockTypeLoop: + mov edx, cSpinWaitLoopCount + mov eax, cLockByteLocked + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + {$else} + mov al, TSmallBlockType([rbx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @NormalLoadLoop + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + je @DidntLock + pop rcx + {Congratulations! We've got the lock!} + jmp @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@SwitchToThread: + call SwitchToThreadIfSupported + jmp @LockSmallBlockTypeLoop + +{$else !SmallBlocksLockedCriticalSection} + +{ The 64-bit implemenation from the original FastMM4 that employs a loop of Sleep() or SwitchToThread(). +By default, it will not be compiled into FastMM4-AVX which uses more efficient approach.} +@LockSmallBlockTypeLoop: + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + mov edx, eax + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType + {Try the next size} + add rbx, Type(TSmallBlockType) + mov eax, edx + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size (up to two sizes larger)} + add rbx, Type(TSmallBlockType) + mov eax, edx + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Block type and two sizes larger are all locked - give up and sleep} + sub rbx, 2 * Type(TSmallBlockType) +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + db $F3, $90 // pause + {$ifdef UseSwitchToThread} + call SwitchToThreadIfSupported + {$endif NeverSleepOnThreadContention} + {Try again} + jmp @LockSmallBlockTypeLoop +{$else NeverSleepOnThreadContention} + {Couldn't grab the block type - sleep and try again} + push rdx {save rdx} + mov ecx, InitialSleepTime + call Sleep + pop rax {restore previous value of rdx straight into rax} + {Try again} + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + mov ecx, AdditionalSleepTime + call Sleep + {Try again} + jmp @LockSmallBlockTypeLoop +{$endif NeverSleepOnThreadContention} +{$endif !SmallBlocksLockedCriticalSection} + +{===== END OF SMALL BLOCK LOCKING CODE; 64-BIT FASTGETMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@AllocateSmallBlockPool: + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLockedForPool +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call LockMediumBlocks +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLockedForPool: + {Are there any available blocks of a suitable size?} + movsx esi, TSmallBlockType[rbx].AllowedGroupsForBlockPoolBitmap + and esi, MediumBlockBinGroupBitmap + jz @NoSuitableMediumBlocks + {Get the bin group number with free blocks in eax} + bsf eax, esi + {Get the bin number in ecx} + lea r8, MediumBlockBinBitmaps + lea r9, [rax * 4] + mov ecx, [r8 + r9] + bsf ecx, ecx + lea ecx, [ecx + r9d * 8] + {Get a pointer to the bin in edi} + lea rdi, MediumBlockBins + lea esi, [ecx * 8] + lea rdi, [rdi + rsi * 2] //SizeOf(TMediumBlockBin) = 16 + {Get the free block in rsi} + mov rsi, TMediumFreeBlock[rdi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov rdx, TMediumFreeBlock[rsi].NextFreeBlock + mov TMediumFreeBlock[rdi].NextFreeBlock, rdx + mov TMediumFreeBlock[rdx].PreviousFreeBlock, rdi + {Is this bin now empty?} + cmp rdi, rdx + jne @MediumBinNotEmpty + {r8 = @MediumBlockBinBitmaps, eax = bin group number, + r9 = bin group number * 4, ecx = bin number, edi = @bin, esi = free block, + ebx = block type} + {Flag this bin as empty} + mov edx, -2 + rol edx, cl + and [r8 + r9], edx + jnz @MediumBinNotEmpty + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBinNotEmpty: + {esi = free block, ebx = block type} + {Get the size of the available medium block in edi} + mov rdi, DropMediumAndLargeFlagsMask + and rdi, [rsi - BlockHeaderSize] + cmp edi, MaximumSmallBlockPoolSize + jb @UseWholeBlock + {Split the block: get the size of the second part, new block size is the + optimal size} + mov edx, edi + movzx edi, TSmallBlockType[rbx].OptimalBlockPoolSize + sub edx, edi + {Split the block in two} + lea rcx, [rsi + rdi] + lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Store the size of the second split as the second last qword} + mov [rcx + rdx - BlockHeaderSize * 2], rdx + {Put the remainder in a bin (it will be big enough)} + call InsertMediumBlockIntoBin + jmp @GotMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NoSuitableMediumBlocks: + {Check the sequential feed medium block pool for space} + movzx ecx, TSmallBlockType[rbx].MinimumBlockPoolSize + mov edi, MediumSequentialFeedBytesLeft + cmp edi, ecx + jb @AllocateNewSequentialFeed + {Get the address of the last block that was fed} + mov rsi, LastSequentiallyFedMediumBlock + {Enough sequential feed space: Will the remainder be usable?} + movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize + lea edx, [ecx + MinimumMediumBlockSize] + cmp edi, edx + jb @NotMuchSpace + mov edi, ecx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotMuchSpace: + sub rsi, rdi + {Update the sequential feed parameters} + sub MediumSequentialFeedBytesLeft, edi + mov LastSequentiallyFedMediumBlock, rsi + {Get the block pointer} + jmp @GotMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@AllocateNewSequentialFeed: + {Need to allocate a new sequential feed medium block pool: use the + optimal size for this small block pool} + movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize + mov edi, ecx + {Allocate the medium block pool} + call AllocNewSequentialFeedMediumPool + mov rsi, rax + test rax, rax + jnz @GotMediumBlock + +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @UnlockSmallBlockAndExit +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@UseWholeBlock: + {rsi = free block, rbx = block type, edi = block size} + {Mark this block as used in the block following it} + and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotMediumBlock: + {rsi = free block, rbx = block type, edi = block size} + {Set the size and flags for this block} + lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag] + mov [rsi - BlockHeaderSize], rcx + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @NotLockedAftrGotMedBlk +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers +(RAX, RCX, RDX, R8, R9, R10, R11), +but we rely on nonvolatile (callee-saved) registers ( RBX, RBP, RDI, RSI, R12)} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotLockedAftrGotMedBlk: + {Set up the block pool} + xor eax, eax + mov TSmallBlockPoolHeader[rsi].BlockType, rbx + mov TSmallBlockPoolHeader[rsi].FirstFreeBlock, rax + mov TSmallBlockPoolHeader[rsi].BlocksInUse, 1 + {Set it up for sequential block serving} + mov TSmallBlockType[rbx].CurrentSequentialFeedPool, rsi + {Return the pointer to the first block} + lea rax, [rsi + SmallBlockPoolHeaderSize] + movzx ecx, TSmallBlockType[rbx].BlockSize + lea rdx, [rax + rcx] + mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rdx + add rdi, rsi + sub rdi, rcx + mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rdi + {Set the small block header} + mov [rax - BlockHeaderSize], rsi + jmp @UnlockSmallBlockAndExit +{-------------------Medium block allocation-------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@NotASmallBlock: + cmp rcx, (MaximumMediumBlockSize - BlockHeaderSize) + ja @IsALargeBlockRequest + {Get the bin size for this block size. Block sizes are + rounded up to the next bin size. + Now we have a designed block size in ecx, it is for sure smaller than 32 bits, + because it is less than the value of the MaximumMediumBlockSize constant, + so we just use ecx/ebx here for smaller opcodes, not rcx/rbx } + lea ebx, [ecx + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset] + and ebx, MediumBlockGranularityMask + add ebx, MediumBlockSizeOffset + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLocked +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call LockMediumBlocks +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLocked: + {Get the bin number in ecx and the group number in edx} + lea edx, [ebx - MinimumMediumBlockSize] + mov ecx, edx + shr edx, 8 + 5 + shr ecx, 8 + {Is there a suitable block inside this group?} + mov eax, -1 + shl eax, cl + lea r8, MediumBlockBinBitmaps + and eax, [r8 + rdx * 4] + jz @GroupIsEmpty + {Get the actual bin number} + and ecx, -MediumBlockBinsPerGroup + bsf eax, eax + or ecx, eax + jmp @GotBinAndGroup + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GroupIsEmpty: + {Try all groups greater than this group} + mov eax, -2 + mov ecx, edx + shl eax, cl + and eax, MediumBlockBinGroupBitmap + jz @TrySequentialFeedMedium + {There is a suitable group with space: get the bin number} + bsf edx, eax + {Get the bin in the group with free blocks} + mov eax, [r8 + rdx * 4] + bsf ecx, eax + mov eax, edx + shl eax, MediumBlockBinsPerGroupPowerOf2 + or ecx, eax + jmp @GotBinAndGroup + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@TrySequentialFeedMedium: + mov ecx, MediumSequentialFeedBytesLeft + {Block can be fed sequentially?} + sub ecx, ebx + jc @AllocateNewSequentialFeedForMedium + {Get the block address} + mov rax, LastSequentiallyFedMediumBlock + sub rax, rbx + mov LastSequentiallyFedMediumBlock, rax + {Store the remaining bytes} + mov MediumSequentialFeedBytesLeft, ecx + {Set the flags for the block} + or rbx, IsMediumBlockFlag + mov [rax - BlockHeaderSize], rbx + jmp @MediumBlockGetDone + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@AllocateNewSequentialFeedForMedium: + mov ecx, ebx + call AllocNewSequentialFeedMediumPool + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlockGetDone: +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point - we only save RAX} + mov rsi, rax + call UnlockMediumBlocks + mov rax, rsi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotBinAndGroup: + {ebx = block size, ecx = bin number, edx = group number} + {Get a pointer to the bin in edi} + lea rdi, MediumBlockBins + lea eax, [ecx + ecx] + lea rdi, [rdi + rax * 8] + {Get the free block in esi} + mov rsi, TMediumFreeBlock[rdi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov rax, TMediumFreeBlock[rsi].NextFreeBlock + mov TMediumFreeBlock[rdi].NextFreeBlock, rax + mov TMediumFreeBlock[rax].PreviousFreeBlock, rdi + {Is this bin now empty?} + cmp rdi, rax + jne @MediumBinNotEmptyForMedium + {edx = bin group number, ecx = bin number, rdi = @bin, rsi = free block, ebx = block size} + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + lea r8, MediumBlockBinBitmaps + and [r8 + rdx * 4], eax + jnz @MediumBinNotEmptyForMedium + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBinNotEmptyForMedium: + {rsi = free block, ebx = block size} + {Get the size of the available medium block in edi} + mov rdi, DropMediumAndLargeFlagsMask + and rdi, [rsi - BlockHeaderSize] + {Get the size of the second split in edx} + mov edx, edi + sub edx, ebx + jz @UseWholeBlockForMedium + {Split the block in two} + lea rcx, [rsi + rbx] + lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Store the size of the second split as the second last dword} + mov [rcx + rdx - BlockHeaderSize * 2], rdx + {Put the remainder in a bin} + cmp edx, MinimumMediumBlockSize + jb @GotMediumBlockForMedium + call InsertMediumBlockIntoBin + jmp @GotMediumBlockForMedium + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@UseWholeBlockForMedium: + {Mark this block as used in the block following it} + and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotMediumBlockForMedium: + {Set the size and flags for this block} + lea rcx, [rbx + IsMediumBlockFlag] + mov [rsi - BlockHeaderSize], rcx + mov rax, rsi + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point - we only save RAX} + call UnlockMediumBlocks + mov rax, rsi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + jmp @Done +{-------------------Large block allocation-------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@IsALargeBlockRequest: + xor rax, rax + test rcx, rcx + js @Done + call AllocateLargeBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@Done: {it automatically restores 4 registers from stack} +{$ifndef AllowAsmParams} + {$ifndef AssumeMultiThreaded} + pop r12 + {$endif} + pop rdi + pop rsi + pop rbx +{$endif} +{$ifdef DEBUG} + test rax, AlignmentMask + jz @@OkAlignmentOnGetMemD + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMemD: +{$endif} + +end; +{$endif} +{$endif FastGetMemNeedAssemblerCode} + +{$ifndef FastFreememNeedAssemberCode} +{Frees a medium block, returning 0 on success, -1 otherwise} +function FreeMediumBlock(APointer: Pointer + {$ifdef UseReleaseStack}; ACleanupOperation: Boolean = false{$endif}): Integer; +var + LNextMediumBlock: PMediumFreeBlock; +{$ifndef FullDebugMode} + LPreviousMediumBlock: PMediumFreeBlock; +{$endif} + LNextMediumBlockSizeAndFlags: NativeUInt; + LBlockSize: Cardinal; +{$ifndef FullDebugMode} + LPreviousMediumBlockSize: Cardinal; +{$endif} +{$ifndef FullDebugMode} + LPPreviousMediumBlockPoolHeader, + LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; +{$endif} + LBlockHeader: NativeUInt; +{$ifdef LogLockContention} + LDidSleep: Boolean; + LStackTrace: TStackTrace; +{$endif} +{$ifdef UseReleaseStack} + LDelayRelease: Boolean; + LPReleaseStack: ^TLFStack; +{$endif} +{$ifndef AssumeMultiThreaded} + LWasMultiThread: Boolean; +{$endif} + LMediumBlocksLocked: Boolean; +begin + LMediumBlocksLocked := False; +{$ifndef AssumeMultiThreaded} + LWasMultiThread := False; +{$endif} +{$ifdef LogLockContention} + LDidSleep := False; +{$endif} + {Get the block header} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Get the medium block size} + LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; + {When running a cleanup operation, medium blocks are already locked.} +{$ifdef UseReleaseStack} + if not ACleanupOperation then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LWasMultiThread := True; +{$endif} + LMediumBlocksLocked := True; + {Lock the medium blocks} + {$ifdef LogLockContention}LDidSleep:={$endif} LockMediumBlocks( + {$ifdef UseReleaseStack}APointer, @LDelayRelease{$endif}); + {$ifdef UseReleaseStack} + if LDelayRelease then + begin + Result := 0; + Exit; + end; + {$endif UseReleaseStack} + end; + end; +{$ifdef LogLockContention} + if LDidSleep then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + MediumBlockCollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif} +{$ifdef UseReleaseStack} + repeat +{$endif} + {Can we combine this block with the next free block?} + LNextMediumBlock := PMediumFreeBlock(PByte(APointer) + LBlockSize); + LNextMediumBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^; +{$ifndef FullDebugMode} + {$ifdef CheckHeapForCorruption} + {Check that this block was flagged as in use in the next block} + if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + {$endif} + if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + {Increase the size of this block} + Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask); + {Remove the next block as well} + if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LNextMediumBlock); + end + else + begin +{$endif} + {Reset the "previous in use" flag of the next block} + PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; +{$ifndef FullDebugMode} + end; + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then + begin + {Get the size of the free block just before this one} + LPreviousMediumBlockSize := PNativeUInt(PByte(APointer) - 2 * BlockHeaderSize)^; + {Get the start of the previous block} + LPreviousMediumBlock := PMediumFreeBlock(PByte(APointer) - LPreviousMediumBlockSize); + {$ifdef CheckHeapForCorruption} + {Check that the previous block is actually free} + if (PNativeUInt(PByte(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + {$endif} + {Set the new block size} + Inc(LBlockSize, LPreviousMediumBlockSize); + {This is the new current block} + APointer := LPreviousMediumBlock; + {Remove the previous block from the linked list} + if LPreviousMediumBlockSize >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPreviousMediumBlock); + end; + {$ifdef CheckHeapForCorruption} + {Check that the previous block is currently flagged as in use} + if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + {$endif} + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block? -> free it. (Except in + full debug mode where medium pools are never freed.)} + if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then + begin + {Store the size of the block as well as the flags} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag); +{$else} + {Mark the block as free} + Inc(PNativeUInt(PByte(APointer) - BlockHeaderSize)^, IsFreeBlockFlag); +{$endif FullDebugMode} + {Store the trailing size marker} + PNativeUInt(PByte(APointer) + LBlockSize - 2 * BlockHeaderSize)^ := LBlockSize; + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + InsertMediumBlockIntoBin(APointer, LBlockSize); +{$ifndef FullDebugMode} + {$ifdef CheckHeapForCorruption} + {Check that this block is actually free and the next and previous blocks are both in use.} + if ((PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) + or ((PNativeUInt(PByte(APointer) + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + {$endif} +{$endif} + {$ifndef UseReleaseStack} +{$ifndef AssumeMultiThreaded} + if LWasMultiThread then +{$endif} + begin + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + {Unlock medium blocks} + UnlockMediumBlocks; + end; + end; + {$endif} + {All OK} + Result := 0; +{$ifndef FullDebugMode} + end + else + begin + {Should this become the new sequential feed?} + if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then + begin + {Bin the current sequential feed} + BinMediumSequentialFeedRemainder; + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + PNativeUInt(PByte(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag; + {Store the number of bytes available in the sequential feed chunk} + MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize; + {Set the last sequentially fed block} + LastSequentiallyFedMediumBlock := Pointer(PByte(APointer) + LBlockSize); + {$ifndef UseReleaseStack} + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + {Unlock medium blocks} + UnlockMediumBlocks; + end; + {$endif} + {Success} + Result := 0; + end + else + begin + {Remove this medium block pool from the linked list} + Dec(PByte(APointer), MediumBlockPoolHeaderSize); + LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer)^.PreviousMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer)^.NextMediumBlockPoolHeader; + LPPreviousMediumBlockPoolHeader^.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader^.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + {Unlock medium blocks} + UnlockMediumBlocks; + end; + {$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + FillChar(APointer^, MediumBlockPoolSize, 0); + {$endif} + {Free the medium block pool} + if VirtualFree(APointer, 0, MEM_RELEASE) then + Result := 0 + else + Result := -1; + {$ifdef UseReleaseStack} + {Medium blocks are already unlocked so we can't continue unwinding the release stack.} + Break; + {$endif UseReleaseStack} + end; + end; +{$endif FullDebugMode} +{$ifdef UseReleaseStack} + if (Result <> 0) or ACleanupOperation then + begin + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + Break; + end; + LPReleaseStack := @MediumReleaseStack[GetStackSlot]; + if LPReleaseStack^.IsEmpty or (not LPReleaseStack.Pop(APointer)) then + begin + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + Break; + end; + {Get the block header} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Get the medium block size} + LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; + until False; +{$endif UseReleaseStack} +end; +{$endif FastFreememNeedAssemberCode} + +{$ifdef DEBUG} +procedure BadAlignmentOnFreeMem; +begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} +end; +{$endif} + +{Replacement for SysFreeMem} +function FastFreeMem(APointer: Pointer): {$ifdef fpc}{$ifdef CPU64}PtrUInt{$else}NativeUInt{$endif}{$else}Integer{$endif}; +{$ifndef FastFreememNeedAssemberCode} +const + CFastFreeMemReturnValueError = {$ifdef fpc}NativeUInt(-1){$else}-1{$endif}; +var + LPSmallBlockPool: PSmallBlockPoolHeader; +{$ifndef FullDebugMode} + LPPreviousPool, + LPNextPool: PSmallBlockPoolHeader; +{$endif} + LPOldFirstPool: PSmallBlockPoolHeader; + LPSmallBlockType: PSmallBlockType; + LOldFirstFreeBlock: Pointer; + LBlockHeader: NativeUInt; +{$ifdef LogLockContention} + LDidSleep: Boolean; + LStackTrace: TStackTrace; +{$endif} +{$ifdef UseReleaseStack} + LPReleaseStack: ^TLFStack; +{$endif} +{$ifdef SmallBlocksLockedCriticalSection} + LSmallBlockCriticalSectionIndex: NativeUInt; + LFailedToAcquireLock: Boolean; +{$endif} +{$ifndef AssumeMultiThreaded} + LWasMultithread: Boolean; +{$endif} + LSmallBlockWithoutLock: Boolean; + LFreeMediumBlockError: Boolean; +begin + LSmallBlockWithoutLock := False; + LFreeMediumBlockError := False; +{$ifndef AssumeMultiThreaded} + LWasMultithread := False; +{$endif} +{$ifdef SmallBlocksLockedCriticalSection} + LSmallBlockCriticalSectionIndex := MaxInt; + LFailedToAcquireLock := False; +{$endif} + {$ifdef fpc} + if APointer = nil then + begin + Result := 0; + Exit; + end; + {$endif} + {Get the small block header: Is it actually a small block?} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if (LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag)) = 0 then + begin + {Get a pointer to the block pool} + LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader); + {Get the block type} + LPSmallBlockType := LPSmallBlockPool^.BlockType; +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + FillChar(APointer^, LPSmallBlockType^.BlockSize - BlockHeaderSize, 0); +{$endif} + {Lock the block type} +{$ifdef LogLockContention} + LDidSleep := False; +{$endif} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + {$ifndef AssumeMultiThreaded} + LWasMultithread := True; + {$endif} + +{$ifdef SmallBlocksLockedCriticalSection} + {$ifndef DisablePauseAndSwitchToThread} + if CpuFeaturePauseAndSwitch then + begin + if not AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + begin + LFailedToAcquireLock := True; + AcquireSpinLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end; + end else + {$endif} + begin + LFailedToAcquireLock := not AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + LSmallBlockCriticalSectionIndex := (NativeUint(LPSmallBlockType)-NativeUint(@(SmallBlockTypes[0]))) + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shr SmallBlockTypeRecSizePowerOf2 + {$else} + div SmallBlockTypeRecSize + {$endif} + ; + EnterCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + if LFailedToAcquireLock then + begin + if not AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + begin + LSmallBlockWithoutLock := True; + end; + end; + end; + +{$else SmallBlocksLockedCriticalSection} + + while not (AcquireLockByte(LPSmallBlockType.SmallBlockTypeLocked)) do + begin +{$ifdef UseReleaseStack} + LPReleaseStack := @(LPSmallBlockType^.ReleaseStack[GetStackSlot]); + if (not LPReleaseStack^.IsFull) and LPReleaseStack^.Push(APointer) then + begin + {Block will be released later.} + Result := 0; + Exit; + end; +{$endif} +{$ifdef LogLockContention} + LDidSleep := True; +{$endif} +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} +{$else} + Sleep(InitialSleepTime); + if AcquireLockByte(LPSmallBlockType^.SmallBlockTypeLocked) then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; + +{$endif SmallBlocksLockedCriticalSection} + + + end; +{$ifdef LogLockContention} + if LDidSleep then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + LPSmallBlockType^.BlockCollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif} +{$ifdef UseReleaseStack} + while True do + begin +{$endif} + {Get the old first free block} + LOldFirstFreeBlock := LPSmallBlockPool^.FirstFreeBlock; + {Was the pool manager previously full?} + if LOldFirstFreeBlock = nil then + begin + {Insert this as the first partially free pool for the block size} + LPOldFirstPool := LPSmallBlockType^.NextPartiallyFreePool; + LPSmallBlockPool^.NextPartiallyFreePool := LPOldFirstPool; + LPOldFirstPool^.PreviousPartiallyFreePool := LPSmallBlockPool; + LPSmallBlockPool^.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); + LPSmallBlockType^.NextPartiallyFreePool := LPSmallBlockPool; + end; + {Store the old first free block} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := UIntPtr(LOldFirstFreeBlock) or IsFreeBlockFlag; + {Store this as the new first free block} + LPSmallBlockPool^.FirstFreeBlock := APointer; + {Decrement the number of allocated blocks} + Dec(LPSmallBlockPool^.BlocksInUse); + {Small block pools are never freed in full debug mode. This increases the + likehood of success in catching objects still being used after being + destroyed.} +{$ifndef FullDebugMode} + {Is the entire pool now free? -> Free it.} + if LPSmallBlockPool^.BlocksInUse = 0 then + begin + {Get the previous and next chunk managers} + LPPreviousPool := LPSmallBlockPool^.PreviousPartiallyFreePool; + LPNextPool := LPSmallBlockPool^.NextPartiallyFreePool; + {Remove this manager} + LPPreviousPool^.NextPartiallyFreePool := LPNextPool; + LPNextPool^.PreviousPartiallyFreePool := LPPreviousPool; + {Is this the sequential feed pool? If so, stop sequential feeding} + if (LPSmallBlockType^.CurrentSequentialFeedPool = LPSmallBlockPool) then + begin + LPSmallBlockType^.MaxSequentialFeedBlockAddress := nil; + end; + {$ifndef AssumeMultiThreaded} + if LWasMultithread then + {$endif} + begin + {Unlock this block type} + if not LSmallBlockWithoutLock then + begin + ReleaseLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end else + begin + LSmallBlockWithoutLock := False; + end; + {$ifdef SmallBlocksLockedCriticalSection} + if LSmallBlockCriticalSectionIndex <> NativeUInt(MaxInt) then + begin + LeaveCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + LSmallBlockCriticalSectionIndex := MaxInt; + end; + {$endif} + end; + {Free the block pool} + if FreeMediumBlock(LPSmallBlockPool) <> 0 then + begin + LFreeMediumBlockError := True; + end; +{$ifdef UseReleaseStack} + {Stop unwinding the release stack.} + Break; +{$endif} + end + else + begin +{$endif} +{$ifdef UseReleaseStack} + LPReleaseStack := @LPSmallBlockType^.ReleaseStack[GetStackSlot]; + if LPReleaseStack^.IsEmpty or (not LPReleaseStack^.Pop(APointer)) then + begin +{$endif} + + {$ifndef AssumeMultiThreaded} + if LWasMultithread then + {$endif} + begin + {Unlock this block type} + if not LSmallBlockWithoutLock then + begin + ReleaseLockByte(LPSmallBlockType^.SmallBlockTypeLocked); + end else + begin + LSmallBlockWithoutLock := False; + end; + {$ifdef SmallBlocksLockedCriticalSection} + if LSmallBlockCriticalSectionIndex <> NativeUInt(MaxInt) then + begin + LeaveCriticalSection(SmallBlockCriticalSections[LSmallBlockCriticalSectionIndex]); + LSmallBlockCriticalSectionIndex := NativeUInt(MaxInt); + end; + {$endif} + end; +{$ifdef UseReleaseStack} + Break; + end; + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader); +{$endif} +{$ifndef FullDebugMode} + end; +{$endif} +{$ifdef UseReleaseStack} + end; +{$endif} + if LFreeMediumBlockError then + begin + Result := CFastFreeMemReturnValueError; + end else + begin + {No error} + Result := 0; + end; + end + else + begin + {Is this a medium block or a large block?} + if (LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag)) = 0 then + begin +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + {Get the block header, extract the block size and clear the block it.} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + FillChar(APointer^, + (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize, 0); +{$endif} + Result := FreeMediumBlock(APointer); + end + else + begin + {Validate: Is this actually a Large block, or is it an attempt to free an + already freed small block?} + if (LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag)) = 0 then + Result := FreeLargeBlock(APointer) + else + Result := CFastFreeMemReturnValueError; + end; + end; +end; +{$else FastFreememNeedAssemberCode} +{$ifdef 32Bit} +assembler; +asm + {$ifdef fpc} + test eax, eax + jne @PointerNotNil + jmp @Finish + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@PointerNotNil: + {$endif} + {Get the block header in edx} + mov edx, [eax - BlockHeaderSize] + {Save the pointer in ecx} + mov ecx, eax +{The EBP register is not used in FastFreeMem, so we will usee it +for flags like IsMultiThreaded or MediumBlocksLocked} + +{$ifndef AssumeMultiThreaded} + push ebp + xor ebp, ebp +{$endif} + + {Save ebx} + push ebx + xor ebx, ebx + + {Get the IsMultiThread variable} +{$ifndef AssumeMultiThreaded} + {Branchless code to avoid misprediction} + cmp byte ptr [IsMultiThread], 0 + setnz bl + shl ebx, StateBitMultithreaded + or ebp, ebx +{$endif} + + + {Is it a small block in use?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {the test+jnz instructions are together to allow macro-op fusion} + jnz @NotSmallBlockInUse +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + push edx + push ecx + mov edx, TSmallBlockPoolHeader[edx].BlockType + movzx edx, TSmallBlockType(edx).BlockSize + sub edx, BlockHeaderSize + xor ecx, ecx + call System.@FillChar + pop ecx + pop edx +{$endif} + {Do we need to lock the block type?} + {Get the small block type in ebx} + mov ebx, TSmallBlockPoolHeader[edx].BlockType + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMultithreaded) + jnz @LockSmallBlockType {test+jnz provide macro-op fusion} + jmp @AfterLock +{$else} + jmp @LockSmallBlockType +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotLockOnSmallBlockType: + {$ifdef SmallBlocksLockedCriticalSection}{$ifdef DebugAcquireLockByte} + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + {$endif}{$endif} +{$ifndef AssumeMultiThreaded} + or ebp, (UnsignedBit shl StateBitSmallLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@AfterLock: + {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 - BlockHeaderSize], eax + {Insert the pool back into the linked list if it was full} + jz @SmallPoolWasFull + {All ok} + xor eax, eax + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} + +@UnlockSmallBlockAndExit: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitSmallLocked) + jz @Exit +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteAvailable + jmp @Exit + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@SmallPoolWasFull: + {Insert this as the first partially free pool for the block size} + mov eax, TSmallBlockType[ebx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx + mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, eax + mov TSmallBlockPoolHeader[eax].PreviousPartiallyFreePool, edx + mov TSmallBlockType[ebx].NextPartiallyFreePool, edx + {All ok} + xor eax, eax + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@PoolIsNowEmpty: + { mark the current block as released to prevent further call to FreeMem} + or dword ptr [ecx - BlockHeaderSize], IsFreeBlockFlag + {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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@IsSequentialFeedPool: + mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotSequentialFeedPool: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitSmallLocked) + jz @DontUnlckSmlBlkAftrNotSeqFdPl +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[ebx].SmallBlockTypeLocked, cLockByteAvailable + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontUnlckSmlBlkAftrNotSeqFdPl: + {Release this pool} + mov eax, edx + mov edx, [edx - 4] + jmp @FreeMediumBlock + +{===== START OF SMALL BLOCK LOCKING CODE; 32-BIT FASTFREEMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockType: +{$ifdef SmallBlocksLockedCriticalSection} + mov eax, cLockByteLocked +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @PrepareForSpinLoop + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@PrepareForSpinLoop: + push edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockTypeLoop: + mov edx, cSpinWaitLoopCount + mov eax, cLockByteLocked + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([ebx]).SmallBlockTypeLocked, al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + {$else} + mov al, TSmallBlockType([ebx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @NormalLoadLoop + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([ebx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + je @DidntLock + {Congratulations! We've got the lock!} + pop edx + jmp @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} + @SwitchToThread: + push ebx + push ecx + push esi + push edi + push ebp + call SwitchToThreadIfSupported + pop ebp + pop edi + pop esi + pop ecx + pop ebx + + jmp @LockSmallBlockTypeLoop + +{$else !SmallBlocksLockedCriticalSection} + +{ The 32-bit implemenation from the original FastMM4 that employs a loop of Sleep() or SwitchToThread(). +By default, it will not be compiled into FastMM4-AVX which uses more efficient approach.} +@LockSmallBlockTypeLoop: + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + db $F3, $90 // pause + {$ifdef UseSwitchToThread} + push ecx + push edx + call SwitchToThreadIfSupported + pop edx + pop ecx + {$endif} + {Try again} + jmp @LockSmallBlockTypeLoop + {Align branch target} +{$else} + {Couldn't grab the block type - sleep and try again} + push ecx + push edx + push InitialSleepTime + call Sleep + pop edx + pop ecx + {Try again} + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + 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 @LockSmallBlockTypeLoop +{$endif} + +{$endif !SmallBlocksLockedCriticalSection} + +{===== END OF SMALL BLOCK LOCKING CODE; 32-BIT FASTFREEMEM =====} + + + {---------------------Medium blocks------------------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotSmallBlockInUse: + {Not a small block in use: is it a medium or large block?} + test dl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @NotASmallOrMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@FreeMediumBlock: +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + push eax + push edx + and edx, DropMediumAndLargeFlagsMask + sub edx, BlockHeaderSize + xor ecx, ecx + call System.@FillChar + pop edx + pop eax +{$endif} + {Drop the flags} + and edx, DropMediumAndLargeFlagsMask + {Free the medium block pointed to by eax, header in edx} + {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} + test ebp, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLocked +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} push ecx; push edx {$endif} + call LockMediumBlocks + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} pop edx; pop ecx {$endif} +{$else} + push edx + call AcquireSpinLockMediumBlocks + pop edx +{$endif} +{$ifndef AssumeMultiThreaded} + or ebp, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLocked: + {Can we combine this block with the next free block?} + test dword ptr [esi + ebx - BlockHeaderSize], IsFreeBlockFlag + {Get the next block size and flags in ecx} + mov ecx, [esi + ebx - BlockHeaderSize] + jnz @NextBlockIsFree + {Set the "PreviousIsFree" flag in the next block} + or ecx, PreviousMediumBlockIsFreeFlag + mov [esi + ebx - BlockHeaderSize], ecx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + jnz @PreviousBlockIsFree + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@BinFreeMediumBlock: + {Store the size of the block as well as the flags} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi - BlockHeaderSize], eax + {Store the trailing size marker} + mov [esi + ebx - BlockHeaderSize*2], 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 +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlckMedBlksAftrBinFrMedBlk +{$endif} + {Unlock medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {it destroys ecx and edx, but we no longer need them} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@DontUnlckMedBlksAftrBinFrMedBlk: + {All OK} + xor eax, eax + {Restore registers} + pop esi + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@PreviousBlockIsFree: + {Get the size of the free block just before this one} + mov ecx, [esi - BlockHeaderSize*2] + {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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlckMedBlcksAftrEntireMedPlFre +{$endif} + {Unlock medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {it destroys eax, ecx and edx, but we don't need them} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontUnlckMedBlcksAftrEntireMedPlFre: +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + mov eax, esi + mov edx, MediumBlockPoolSize + xor ecx, ecx + call System.@FillChar +{$endif} + {Free the medium block pool} + push MEM_RELEASE + push 0 + push esi + call VirtualFree + {VirtualFree returns >0 if all is ok} + cmp eax, 1 + {Return 0 on all ok} + sbb eax, eax + {Restore registers} + pop esi + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 +{$ifndef AssumeMultiThreaded} + test ebp, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlckMedBlksAftrMkEmptMedPlSeqFd +{$endif} + {Unlock medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {it destroys eax, ecx and edx, but we don't need them} +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@DontUnlckMedBlksAftrMkEmptMedPlSeqFd: + {Success} + xor eax, eax + {Restore registers} + pop esi + jmp @Exit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotASmallOrMediumBlock: + {Is it in fact a large block?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + jnz @DontFreeLargeBlock + pop ebx +{$ifndef AssumeMultiThreaded} + pop ebp +{$endif} + call FreeLargeBlock + jmp @Finish + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontFreeLargeBlock: + {Attempt to free an already free block} + mov eax, -1 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@Exit: + pop ebx +{$ifndef AssumeMultiThreaded} + pop ebp +{$endif} +@Finish: +end; + +{$else 32Bit} + +{---------------64-bit BASM FastFreeMem---------------} +assembler; // rcx = address +asm + {$ifdef DEBUG} + test rcx, AlignmentMask + jz @@OkAlign + jmp BadAlignmentOnFreeMem +@@OkAlign: + {$endif} + + {Do not put ".noframe" here, for the reasons given at the comment + in the "BinMediumSequentialFeedRemainder" function at the start of the + 64-bit assembly code} + {$ifdef AllowAsmParams} + .params 3 + .pushnv rbx + .pushnv rsi + {$ifndef AssumeMultiThreaded} + .pushnv r12 + {$endif} + {$else} + push rbx + push rsi + {$ifndef AssumeMultiThreaded} + push r12 + {$endif} + {$endif} + +{$ifndef AssumeMultiThreaded} + xor r12, r12 + {Get the IsMultiThread variable so long} + lea rsi, [IsMultiThread] + movzx esi, byte ptr [rsi] {this also clears highest bits of the rsi register} + test esi, esi + setnz sil + shl esi, StateBitMultithreaded + or r12, rsi +{$endif} + + {Get the block header in rdx} + mov rdx, [rcx - BlockHeaderSize] + {Is it a small block in use?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {put test+jnz together to allow macro-op fusion} + jnz @NotSmallBlockInUse +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + mov rsi, rcx + mov rdx, TSmallBlockPoolHeader[rdx].BlockType + movzx edx, TSmallBlockType(rdx).BlockSize + sub edx, BlockHeaderSize + xor r8, r8 + call System.@FillChar + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] +{$endif} + {Get the small block type in rbx} + mov rbx, TSmallBlockPoolHeader[rdx].BlockType + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMultithreaded) + jnz @LockSmallBlockType // test+jnz are together to allow macro-op fusion + call @FreememMain + jmp @Done +{$else} + jmp @LockSmallBlockType +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@GotLockOnSmallBlockType: + {$ifdef SmallBlocksLockedCriticalSection}{$ifdef DebugAcquireLockByte} + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + {$endif}{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitSmallLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@AfterLockOnSmallBlockType: + + {Current state: rdx = @SmallBlockPoolHeader, rcx = APointer, rbx = @SmallBlockType} + {Decrement the number of blocks in use} + sub TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Get the old first free block} + mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock + {Is the pool now empty?} + jz @PoolIsNowEmpty + {Was the pool full?} + test rax, rax + {Store this as the new first free block} + mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx + {Store the previous first free block as the block header} + lea rax, [rax + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Insert the pool back into the linked list if it was full} + jz @SmallPoolWasFull + {All ok} + xor eax, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@UnlockSmallBlockAndExit: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitSmallLocked) + jz @Done +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteAvailable + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@SmallPoolWasFull: + {Insert this as the first partially free pool for the block size} + mov rcx, TSmallBlockType[rbx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool, rbx + mov TSmallBlockPoolHeader[rdx].NextPartiallyFreePool, rcx + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rdx + mov TSmallBlockType[rbx].NextPartiallyFreePool, rdx + {All ok} + xor eax, eax + jmp @UnlockSmallBlockAndExit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@PoolIsNowEmpty: + { mark the current block as released to prevent further call to FreeMem} + or dword ptr [rcx-BlockHeaderSize], IsFreeBlockFlag + {Was this pool actually in the linked list of pools with space? If not, it + can only be the sequential feed pool (it is the only pool that may contain + only one block, i.e. other blocks have not been split off yet)} + test rax, rax + jz @IsSequentialFeedPool + {Pool is now empty: Remove it from the linked list and free it} + mov rax, TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool + mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool + {Remove this manager} + mov TSmallBlockPoolHeader[rax].NextPartiallyFreePool, rcx + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rax + {Zero out eax} + xor rax, rax + {Is this the sequential feed pool? If so, stop sequential feeding} + cmp TSmallBlockType[rbx].CurrentSequentialFeedPool, rdx + jne @NotSequentialFeedPool + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@IsSequentialFeedPool: + mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotSequentialFeedPool: + {Unlock the block type} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitSmallLocked) + jz @DontRelSmlBlkAftrNotSeqFdPl +{$endif} + {$ifdef DebugReleaseLockByte} + cmp TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteLocked + jne SmallBlockUnlockError + {$endif} +{$ifdef InterlockedRelease} + lock +{$endif} + mov TSmallBlockType[rbx].SmallBlockTypeLocked, cLockByteAvailable + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontRelSmlBlkAftrNotSeqFdPl: + {Release this pool} + mov rcx, rdx + mov rdx, [rdx - BlockHeaderSize] + jmp @FreeMediumBlock + +{===== START OF SMALL BLOCK LOCKING CODE; 64-BIT FASTFREEMEM =====} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockType: + +{$ifdef SmallBlocksLockedCriticalSection} + + mov eax, cLockByteLocked + + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @PrepareForSpinLoop + {$else} + mov al, TSmallBlockType([rbx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @PrepareForSpinLoop + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + jne @GotLockOnSmallBlockType + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 2{$endif} +@PrepareForSpinLoop: + push rcx + push rdx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@LockSmallBlockTypeLoop: + mov eax, cLockByteLocked + mov edx, cSpinWaitLoopCount + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 16{$endif} +@DidntLock: +@NormalLoadLoop: + dec edx + jz @SwitchToThread // for static branch prediction, jump forward means "unlikely" + db $F3, $90 // pause + {$ifndef DebugAcquireLockByte} +// use the "test, test-and-set" technique, details are in the comment section at the beginning of the file + cmp TSmallBlockType([rbx]).SmallBlockTypeLocked, al + je @NormalLoadLoop // for static branch prediction, jump backwards means "likely" + {$else} + mov al, TSmallBlockType([rbx]).SmallBlockTypeLocked + cmp al, cLockByteLocked + je @NormalLoadLoop + cmp al, cLockByteAvailable + jne SmallBlockUnlockError + mov eax, cLockByteLocked + {$endif} + lock xchg TSmallBlockType([rbx]).SmallBlockTypeLocked, al + cmp al, cLockByteLocked + je @DidntLock + {Congratulations! We've got the lock!} + pop rdx + pop rcx + jmp @GotLockOnSmallBlockType + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 4{$endif} +@SwitchToThread: + call SwitchToThreadIfSupported + jmp @LockSmallBlockTypeLoop + +{$else !SmallBlocksLockedCriticalSection} + +{ The 64-bit implemenation from the original FastMM4 that employs a loop of Sleep() or SwitchToThread(). +By default, it will not be compiled into FastMM4-AVX which uses more efficient approach.} +@LockSmallBlockTypeLoop: + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + db $F3, $90 // pause + {$ifdef UseSwitchToThread} + mov rsi, rcx + call SwitchToThreadIfSupported + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {$endif} + {Try again} + jmp @LockSmallBlockTypeLoop +{$else} + {Couldn't grab the block type - sleep and try again} + mov rsi, rcx + mov ecx, InitialSleepTime + call Sleep + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {Try again} + mov eax, (cLockbyteLocked shl 8) or cLockByteAvailable + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).SmallBlockTypeLocked, ah // cmpxchg also uses AL as an implicit operand + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + mov rsi, rcx + mov ecx, AdditionalSleepTime + call Sleep + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {Try again} + jmp @LockSmallBlockTypeLoop +{$endif} + +{$endif !SmallBlocksLockedCriticalSection} + +{===== END OF SMALL BLOCK LOCKING CODE; 64-BIT FASTFREEMEM =====} + + {---------------------Medium blocks------------------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotSmallBlockInUse: + {Not a small block in use: is it a medium or large block?} + test dl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @NotASmallOrMediumBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@FreeMediumBlock: +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + mov rsi, rcx + and rdx, DropMediumAndLargeFlagsMask + sub rdx, BlockHeaderSize + xor r8, r8 + call System.@FillChar + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] +{$endif} + {Drop the flags} + and rdx, DropMediumAndLargeFlagsMask + {Free the medium block pointed to by eax, header in edx} + {Block size in rbx} + mov rbx, rdx + {Pointer in rsi} + mov rsi, rcx + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMultithreaded) + jz @MediumBlocksLocked // put test+jz together to allow macro-op fusion +{$endif} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them, since we keep our data +in nonvolatile (callee-saved) registers like RBX, RSI, and R12} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call LockMediumBlocks +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MediumBlocksLocked: + {Can we combine this block with the next free block?} + test qword ptr [rsi + rbx - BlockHeaderSize], IsFreeBlockFlag + {Get the next block size and flags in rcx} + mov rcx, [rsi + rbx - BlockHeaderSize] + jnz @NextBlockIsFree + {Set the "PreviousIsFree" flag in the next block} + or rcx, PreviousMediumBlockIsFreeFlag + mov [rsi + rbx - BlockHeaderSize], rcx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NextBlockChecked: + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + test byte ptr [rsi - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + jnz @PreviousBlockIsFree + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@BinFreeMediumBlock: + {Store the size of the block as well as the flags} + lea rax, [rbx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rsi - BlockHeaderSize], rax + {Store the trailing size marker} + mov [rsi + rbx - 2 * BlockHeaderSize], rbx + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + mov rcx, rsi + mov rdx, rbx + {Insert into bin} + call InsertMediumBlockIntoBin + {All OK} + xor eax, eax + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + xor eax, eax + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NextBlockIsFree: + {Get the next block address in rax} + lea rax, [rsi + rbx] + {Increase the size of this block} + and rcx, DropMediumAndLargeFlagsMask + add rbx, rcx + {Was the block binned?} + cmp rcx, MinimumMediumBlockSize + jb @NextBlockChecked + mov rcx, rax + call RemoveMediumFreeBlock + jmp @NextBlockChecked + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@PreviousBlockIsFree: + {Get the size of the free block just before this one} + mov rcx, [rsi - 2 * BlockHeaderSize] + {Include the previous block} + sub rsi, rcx + {Set the new block size} + add rbx, rcx + {Remove the previous block from the linked list} + cmp ecx, MinimumMediumBlockSize + jb @PreviousBlockChecked + mov rcx, rsi + call RemoveMediumFreeBlock + jmp @PreviousBlockChecked + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@EntireMediumPoolFree: + {Should we make this the new sequential feed medium block pool? If the + current sequential feed pool is not entirely free, we make this the new + sequential feed pool.} + lea r8, MediumSequentialFeedBytesLeft + cmp dword ptr [r8], MediumBlockPoolSize - MediumBlockPoolHeaderSize //workaround for QC99023 + jne @MakeEmptyMediumPoolSequentialFeed + {Point esi to the medium block pool header} + sub rsi, MediumBlockPoolHeaderSize + {Remove this medium block pool from the linked list} + mov rax, TMediumBlockPoolHeader[rsi].PreviousMediumBlockPoolHeader + mov rdx, TMediumBlockPoolHeader[rsi].NextMediumBlockPoolHeader + mov TMediumBlockPoolHeader[rax].NextMediumBlockPoolHeader, rdx + mov TMediumBlockPoolHeader[rdx].PreviousMediumBlockPoolHeader, rax + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlckMedBlcksAftrEntireMedPlFre +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@DontUnlckMedBlcksAftrEntireMedPlFre: +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + mov rcx, rsi + mov edx, MediumBlockPoolSize + xor r8, r8 + call System.@FillChar +{$endif} + {Free the medium block pool} + mov rcx, rsi + xor edx, edx + mov r8d, MEM_RELEASE + call VirtualFree + {VirtualFree returns >0 if all is ok} + cmp eax, 1 + {Return 0 on all ok} + sbb eax, eax + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@MakeEmptyMediumPoolSequentialFeed: + {Get a pointer to the end-marker block} + lea rbx, [rsi + MediumBlockPoolSize - MediumBlockPoolHeaderSize] + {Bin the current sequential feed pool} + call BinMediumSequentialFeedRemainder + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + mov qword ptr [rbx - BlockHeaderSize], IsMediumBlockFlag + {Store the number of bytes available in the sequential feed chunk} + lea rax, MediumSequentialFeedBytesLeft + mov dword ptr [rax], MediumBlockPoolSize - MediumBlockPoolHeaderSize //QC99023 workaround + {Set the last sequentially fed block} + mov LastSequentiallyFedMediumBlock, rbx + {Success} + xor eax, eax + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point} + call UnlockMediumBlocks +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + xor eax, eax + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@NotASmallOrMediumBlock: + {Attempt to free an already free block?} + mov eax, -1 + {Is it in fact a large block?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + jnz @Done + call FreeLargeBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNodot}align{$else}.align{$endif} 8{$endif} +@Done: {automatically restores registers from stack by implicitly inserting pop instructions (rbx, rsi and r12)} +{$ifndef AllowAsmParams} + {$ifndef AssumeMultiThreaded} + pop r12 + {$endif} + pop rsi + pop rbx +{$endif} +end; +{$endif 32Bit} +{$endif FastFreememNeedAssemberCode} + + +{$ifndef FullDebugMode} +{Replacement for SysReallocMem} +function FastReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; +{$ifndef FastReallocMemNeedAssemberCode} + + {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.} + +var + LBlockFlags, + LNextBlockSizeAndFlags, + LMinimumUpsize, + LOldAvailableSize, + LNewAllocSize, + LNewBlockSize, + LNewAvailableSize: NativeUInt; + LPNextBlock: Pointer; + LPNextBlockHeader: Pointer; + LSecondSplitSize: NativeUInt; + + procedure MediumBlockInPlaceUpsize; + var + LSum: NativeUInt; + begin + {Remove the next block} + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + {Add 25% for medium block in-place upsizes} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if NativeUInt(ANewSize) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := NativeUInt(ANewSize); + {Round up to the nearest block size granularity} + LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and MediumBlockGranularityMask) + MediumBlockSizeOffset; + {Does it fit?} + LSum := LNewAvailableSize + BlockHeaderSize; + if LSum <= LNewBlockSize then + begin + LSecondSplitSize := NativeUInt(-1); + {The block size is the full available size plus header} + LNewBlockSize := LNewAvailableSize + BlockHeaderSize; + {Grab the whole block: Mark it as used in the block following it} + LPNextBlockHeader := Pointer(PByte(APointer) + LNewAvailableSize); + PNativeUInt(LPNextBlockHeader)^ := + PNativeUInt(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag); + end + else + begin + LSecondSplitSize := LSum - LNewBlockSize; + {Split the block in two} + LPNextBlock := PMediumFreeBlock(PByte(APointer) + LNewBlockSize); + {Set the size of the second split} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split before the header of the next block} + PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Put the remainder in a bin if it is big enough} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + end; + {Set the size and flags for this block} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags; + end; + + {In-place downsize of a medium block. On entry Size must be less than half of + LOldAvailableSize.} + procedure MediumBlockInPlaceDownsize; +{$ifdef LogLockContention} + var + LDidSleep: Boolean; +{$endif} + var + LWasMultiThreadMediumBlocks: Boolean; + begin + LWasMultiThreadMediumBlocks := False; + + {Round up to the next medium block size} + LNewBlockSize := ((NativeUInt(ANewSize) + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and MediumBlockGranularityMask) + MediumBlockSizeOffset; + {Get the size of the second split} + LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize; + {Lock the medium blocks} + +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + LWasMultiThreadMediumBlocks := True; + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + {$ifdef LogLockContention} + if LDidSleep then + LCollector := @MediumBlockCollector; + {$endif} + end; + {Set the new size} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) + or LNewBlockSize; + {Is the next block in use?} + LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize + BlockHeaderSize); + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + if (LNextBlockSizeAndFlags and IsFreeBlockFlag) = 0 then + begin + {The next block is in use: flag its previous block as free} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := + LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + end + else + begin + {The next block is free: combine it} + LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Inc(LSecondSplitSize, LNextBlockSizeAndFlags); + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + end; + {Set the split} + LPNextBlock := PNativeUInt(PByte(APointer) + LNewBlockSize); + {Store the free part's header} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the trailing size field} + PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Bin this free block} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + if LWasMultiThreadMediumBlocks then + begin + LWasMultiThreadMediumBlocks := False; + {Unlock the medium blocks} + UnlockMediumBlocks; + end; + end; + +var + LBlockHeader, + LNextBlockSize: NativeUInt; + LPSmallBlockType: PSmallBlockType; +{$ifdef LogLockContention} + LCollector: PStaticCollector; +{$endif} + +var +{$ifdef LogLockContention} + LDidSleep: Boolean; + LStackTrace: TStackTrace; +{$endif} +{$ifndef AssumeMultiThreaded} + LWasMultithread: Boolean; +{$endif} + LWasMediumBlockLocked: Boolean; +begin +{$ifndef AssumeMultiThreaded} + LWasMultithread := False; +{$endif} + LWasMediumBlockLocked := False; +{$ifdef fpc} + if APointer = nil then + begin + if ANewSize <> 0 then + APointer := FastGetMem(ANewSize); + Result := APointer; + Exit; + end + else if ANewSize = 0 then + begin + FastFreeMem(APointer); + APointer := nil; + Result := APointer; + Exit; + end; +{$endif} +{$ifdef LogLockContention} + LCollector := nil; + LPSmallBlockType := nil; // to remove "uninitialized" warning in the "finally" block + try +{$endif} + {Get the block header: Is it actually a small block?} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if ((LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag))) = 0 then + begin + {-----------------------------------Small block-------------------------------------} + {The block header is a pointer to the block pool: Get the block type} + LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader)^.BlockType; + {Get the available size inside blocks of this type.} + LOldAvailableSize := LPSmallBlockType^.BlockSize - BlockHeaderSize; + {Is it an upsize or a downsize?} + if LOldAvailableSize >= NativeUInt(ANewSize) then + begin + {It's a downsize. Do we need to allocate a smaller block? Only if the new + block size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + if (NativeUInt(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then + begin + {In-place downsize - return the pointer} + Result := APointer; + Exit; + end + else + begin + {Allocate a smaller block} + Result := FastGetMem(ANewSize); + {Allocated OK?} + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + MoveX32LPUniversal(APointer^, Result^, ANewSize); + {$else} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, ANewSize); + {$else} + MoveX8LP(APointer^, Result^, ANewSize); + {$endif} + {$endif} +{$else} + System.Move(APointer^, Result^, ANewSize); +{$endif} + {Free the old pointer} + FastFreeMem(APointer); + end; + end; + end + else + begin + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Must grow with at least 100% + x bytes} + LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder; + {Still not large enough?} + if LNewAllocSize < NativeUInt(ANewSize) then + LNewAllocSize := NativeUInt(ANewSize); + {Allocate the new block} + Result := FastGetMem(LNewAllocSize); + {Allocated OK?} + if Result <> nil then + begin + {Do we need to store the requested size? Only large blocks store the + requested size.} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + LPSmallBlockType^.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize); +{$else} + System.Move(APointer^, Result^, LOldAvailableSize); +{$endif} + {Free the old pointer} + FastFreeMem(APointer); + end; + end; + end + else + begin + {Is this a medium block or a large block?} + if ((LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag))) = 0 then + begin + {-------------------------------Medium block--------------------------------------} + {What is the available size in the block being reallocated?} + LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask); + {Get a pointer to the next block} + LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize); + {Subtract the block header size from the old available size} + Dec(LOldAvailableSize, BlockHeaderSize); + {Is it an upsize or a downsize?} + if NativeUInt(ANewSize) > LOldAvailableSize then + begin + {Can we do an in-place upsize?} + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + {Is the next block free?} + if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Can the block fit?} + if NativeUInt(ANewSize) <= LNewAvailableSize then + begin + {The next block is free and there is enough space to grow this + block in place.} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then + begin + LWasMultithread := True; +{$endif} + {Multi-threaded application - lock medium blocks and re-read the + information on the blocks.} + LWasMediumBlockLocked := True; + + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; +{$ifdef LogLockContention} + if LDidSleep then + LCollector := @MediumBlockCollector; +{$endif} + {Re-read the info for this block} + LBlockFlags := PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask; + {Re-read the info for the next block} + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + {Recalculate the next block size} + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Is the next block still free and the size still sufficient?} + if ((LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0) + and (NativeUInt(ANewSize) <= LNewAvailableSize) then + begin + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + if LWasMediumBlockLocked then + begin + LWasMediumBlockLocked := False; + {Unlock the medium blocks} + UnlockMediumBlocks; + end; + {Return the result} + Result := APointer; + {Done} + Exit; + end; + if LWasMediumBlockLocked then + begin + LWasMediumBlockLocked := False; + {Couldn't use the block: Unlock the medium blocks} + UnlockMediumBlocks; + end; +{$ifndef AssumeMultiThreaded} + end + else + begin + {Extract the block flags} + LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader; + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + {Return the result} + Result := APointer; + {Done} + Exit; + end; +{$endif} + end; + end; + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if NativeUInt(ANewSize) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := NativeUInt(ANewSize); + {Allocate the new block} + Result := FastGetMem(LNewAllocSize); + if Result <> nil then + begin + {If it's a large block - store the actual user requested size} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize)^.UserAllocatedSize := ANewSize; + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + MoveX32LPUniversal(APointer^, Result^, LOldAvailableSize); + {$else} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, LOldAvailableSize); + {$else} + MoveX8LP(APointer^, Result^, LOldAvailableSize); + {$endif} + {$endif} +{$else} + System.Move(APointer^, Result^, LOldAvailableSize); +{$endif} + {Free the old block} + FastFreeMem(APointer); + end; + end + else + begin + {Must be less than half the current size or we don't bother resizing.} + if (NativeUInt(ANewSize) shl 1) >= LOldAvailableSize then + begin + Result := APointer; + end + else + begin + {In-place downsize? Balance the cost of moving the data vs. the cost + of fragmenting the memory pool. Medium blocks in use may never be + smaller than MinimumMediumBlockSize.} + if NativeUInt(ANewSize) >= (MinimumMediumBlockSize - BlockHeaderSize) then + begin + MediumBlockInPlaceDownsize; + Result := APointer; + end + else + begin + {The requested size is less than the minimum medium block size. If + the requested size is less than the threshold value (currently a + quarter of the minimum medium block size), move the data to a small + block, otherwise shrink the medium block to the minimum allowable + medium block size.} + if NativeUInt(ANewSize) >= MediumInPlaceDownsizeLimit then + begin + {The request is for a size smaller than the minimum medium block + size, but not small enough to justify moving data: Reduce the + block size to the minimum medium block size} + ANewSize := MinimumMediumBlockSize - BlockHeaderSize; + {Is it already at the minimum medium block size?} + if LOldAvailableSize > NativeUInt(ANewSize) then + MediumBlockInPlaceDownsize; + Result := APointer; + end + else + begin + {Allocate the new block} + Result := FastGetMem(ANewSize); + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + MoveX32LPUniversal(APointer^, Result^, ANewSize); + {$else} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, ANewSize); + {$else} + MoveX8LP(APointer^, Result^, ANewSize); + {$endif} + {$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; +{$ifdef fpc} + APointer := Result; +{$endif} +{$ifdef LogLockContention} + finally + if Assigned(LCollector) then + begin + GetStackTrace(@(LStackTrace[0]), StackTraceDepth, 1); + LPSmallBlockType.BlockCollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; + end; +{$endif} +end; +{$else FastReallocMemNeedAssemberCode} +{$ifdef 32Bit} +assembler; +{$ifndef AssumeMultiThreaded} +const + cLocalVarStackOfsMediumBlock = 4 {size of a 32-bit register} * 4 {4 saved registers to skip for a medium block}; +{$endif} +asm +{$ifdef fpc} + push esi + mov esi, eax + mov eax, [esi] + test eax, eax + jne @PointerNotNil + test edx, edx + je @SizeIsZero + mov eax, edx + call FastGetMem + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem1 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem1: + {$endif} + mov [esi], eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 2{$endif} +@SizeIsZero: + pop esi + jmp @Final + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@PointerNotNil: + test edx, edx + jne @GoRealloc + call FastFreeMem + mov dword ptr [esi], 0 + pop esi + jmp @Final + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@GoRealloc: +{$endif} + {On entry: eax = APointer; edx = ANewSize} + {Get the block header: Is it actually a small block?} + +{$ifdef AssumeMultiThreaded} + push 0 // empty local variable into the stack +{$else} + {Branchless operations to avoid misprediction} + cmp byte ptr [IsMultiThread], 0 + setnz cl + movzx ecx, cl + shl ecx, StateBitMultithreaded + push ecx // put local variable into the stack +{$endif} + + + mov ecx, [eax - BlockHeaderSize] + {Save ebx} + push ebx + {Save esi} + push esi + {Save the original pointer in esi} + mov esi, eax + {Is it a small block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + jnz @NotASmallBlock {test+jnz provides macro-op fusion} + {-----------------------------------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 + jnb @Exit2Reg +//@NotSmallInPlaceDownsize: + {Save the requested size} + mov ebx, edx + {Allocate a smaller block} + mov eax, edx + call FastGetMem + {Allocated OK?} + test eax, eax + jz @Exit2Reg + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem2 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem2: + {$endif} + {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 Align32Bytes} + call MoveX32LPUniversal + {$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} + {$endif} +{$else} + call System.Move +{$endif} + {Free the original pointer} + mov eax, esi + call FastFreeMem + {Return the pointer} + mov eax, ebx + jmp @Exit2Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 @Exit3Reg + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem3 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem3: + {$endif} + {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 - BlockHeaderSize*2], edi + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 + jmp @Exit3Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 + + {Save ebp} + push ebp + + {Is it an upsize or a downsize?} + cmp edx, ecx + ja @MediumBlockUpsize {cmp+ja provides macro-op fusion} + {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 + jnb @Exit4Reg + {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 @Exit4Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumBlockInPlaceDownsize: + {Round up to the next medium block size} + lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and ebp, MediumBlockGranularityMask + add ebp, MediumBlockSizeOffset + {Get the size of the second split} + add ecx, BlockHeaderSize + sub ecx, ebp + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + test byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMultithreaded) + jz @DoMediumInPlaceDownsize +{$endif} +//@DoMediumLockForDownsize: + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {When ussing UseOriginalFastMM4_LockMediumBlocksAsm, it preserves all registers + (except eax), including ecx} + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} push ecx; push edx {$endif} + call LockMediumBlocks + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} pop edx; pop ecx {$endif} +{$else} + push edx + call AcquireSpinLockMediumBlocks + pop edx +{$endif} +{$ifndef AssumeMultiThreaded} + or byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMediumLocked) +{$endif} + + {Reread the flags - they may have changed before medium blocks could be + locked.} + mov ebx, ExtractMediumAndLargeFlagsMask + and ebx, [esi - BlockHeaderSize] + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DoMediumInPlaceDownsize: + {Set the new size} + or ebx, ebp + mov [esi - BlockHeaderSize], ebx + {Get the second split size in ebx} + mov ebx, ecx + {Is the next block in use?} + mov edx, [edi - BlockHeaderSize] + test dl, IsFreeBlockFlag + jnz @MediumDownsizeNextBlockFree + {The next block is in use: flag its previous block as free} + or edx, PreviousMediumBlockIsFreeFlag + mov [edi - BlockHeaderSize], edx + jmp @MediumDownsizeDoSplit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumDownsizeDoSplit: + {Store the trailing size field} + mov [edi - BlockHeaderSize*2], ebx + {Store the free part's header} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]; + mov [esi + ebp - BlockHeaderSize], eax + {Bin this free block} + cmp ebx, MinimumMediumBlockSize + jb @MediumBlockDownsizeDone + lea eax, [esi + ebp] + mov edx, ebx + call InsertMediumBlockIntoBin + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumBlockDownsizeDone: + {Result = old pointer} + mov eax, esi +{$ifndef AssumeMultiThreaded} + test byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMediumLocked) + jz @Exit4Reg +{$endif} + {Unlock the medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {this call destroys eax, ecx, edx, but we don't need them, since we are about to exit} + {Result = old pointer} + mov eax, esi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + jmp @Exit4Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumDownsizeRealloc: + {Save the requested size} + mov edi, edx + mov eax, edx + {Allocate the new block} + call FastGetMem + test eax, eax + jz @Exit4Reg + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem4 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem4: + {$endif} + + {Save the result} + mov ebp, eax + mov edx, eax + mov eax, esi + mov ecx, edi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + call MoveX32LPUniversal + {$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} + {$endif} +{$else} + call System.Move +{$endif} + mov eax, esi + call FastFreeMem + {Return the result} + mov eax, ebp + jmp @Exit4Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 - BlockHeaderSize] + 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} + test byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMultithreaded) + je @DoMediumInPlaceUpsize +{$endif} +//@DoMediumLockForUpsize: + {Lock the medium blocks (ecx and edx *must* be preserved} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} push ecx; push edx {$endif} + call LockMediumBlocks + {$ifndef UseOriginalFastMM4_LockMediumBlocksAsm} pop edx; pop ecx {$endif} +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMediumLocked) +{$endif} + {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 - BlockHeaderSize] + {Re-read the info for the next block} + mov eax, [edi - BlockHeaderSize] + {Next block still free?} + test al, IsFreeBlockFlag + jz @NextMediumBlockChanged + {Recalculate the next block size} + and eax, DropMediumAndLargeFlagsMask + {The available size including the next block} + lea ebp, [eax + ecx] + {Can the block still fit?} + cmp edx, ebp + ja @NextMediumBlockChanged + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@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, MediumBlockGranularityMask + 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, BlockHeaderSize + {Upsize done} + jmp @MediumUpsizeInPlaceDone + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumInPlaceUpsizeSplit: + {Store the size of the second split as the second last dword} + mov [esi + ebp - BlockHeaderSize], edx + {Set the second split header} + lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi + eax - BlockHeaderSize], edi + mov ebp, eax + cmp edx, MinimumMediumBlockSize + jb @MediumUpsizeInPlaceDone + add eax, esi + call InsertMediumBlockIntoBin + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumUpsizeInPlaceDone: + {Set the size and flags for this block} + or ebp, ebx + mov [esi - BlockHeaderSize], ebp + + {Result = old pointer} + mov eax, esi + +{$ifndef AssumeMultiThreaded} + test byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMediumLocked) + jz @Exit4Reg +{$endif} + {Unlock the medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + call UnlockMediumBlocks {this call destroys eax, ecx, edx, but we don't need them now since we are about to exit} + {Result = old pointer} + mov eax, esi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + jmp @Exit4Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@NextMediumBlockChanged: +{$ifndef AssumeMultiThreaded} + test byte ptr ss:[esp+cLocalVarStackOfsMediumBlock], (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlMedBlksAftrNxtMedBlkChg +{$endif} + {The next medium block changed while the medium blocks were being locked} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + push ecx + push edx + call UnlockMediumBlocks {this function destroys eax, ecx and edx, so we save ecx and edx} + pop edx + pop ecx +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} + +@DontUnlMedBlksAftrNxtMedBlkChg: + +@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 @Exit4Reg + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem5 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem5: + {$endif} + {If it's a Large block - store the actual user requested size} + cmp ebp, MaximumMediumBlockSize - BlockHeaderSize + jbe @MediumUpsizeNotLarge + mov [eax - BlockHeaderSize*2], edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@MediumUpsizeNotLarge: + {Save the result} + mov ebp, eax + {Move the data across} + mov edx, eax + mov eax, esi + mov ecx, edi +{$ifdef UseCustomVariableSizeMoveRoutines} +{$ifdef Align32Bytes} + call MoveX32LPUniversal +{$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} +{$endif} +{$else} + call System.Move +{$endif} + {Free the old block} + mov eax, esi + call FastFreeMem + {Restore the result} + mov eax, ebp + jmp @Exit4Reg + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@PossibleLargeBlock: + {-----------------------Large block------------------------------} + {Restore registers} + pop esi + pop ebx + add esp, 4 {remove local variable, 4=size of 32-bit register} + {Is this a valid large block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag +{$ifndef fpc} + jz ReallocateLargeBlock +{$else} + jnz @FpcError + call ReallocateLargeBlock + jmp @FpcDone + {-----------------------Invalid block------------------------------} +@FpcError: +{$endif} + xor eax, eax +{$ifdef fpc} +@FpcDone: + mov [esi], eax + pop esi + jmp @FpcExitStrackRestored +{$endif} + +{Don't need alignment here since all instructions are just one-byte} +@Exit4Reg: {return, restoring 4 registers from the stack and one local variable} + pop ebp +@Exit3Reg: {return, restoring 3 registers from the stack and one local variable} + pop edi +@Exit2Reg: {return, restoring 2 registers from the stack and one local variable} + pop esi + pop ebx + add esp, 4 {remove local variable, 4=size of 32-bit register} + +{$ifdef fpc} + mov [esi], eax + pop esi +{$endif} + +{$ifdef fpc} +@FpcExitStrackRestored: +{$endif} +@Final: +end; + +{$else} + +{-----------------64-bit BASM FastReallocMem-----------------} +assembler; +asm + {Do not put ".noframe" here, for the reasons given at the comment + in the "BinMediumSequentialFeedRemainder" function at the start of the + 64-bit assembler code} + {$ifdef AllowAsmParams} + .params 3 + .pushnv rbx + .pushnv rsi + .pushnv rdi + {$ifndef AssumeMultiThreaded} + .pushnv r12 + {$endif} + .pushnv r14 + .pushnv r15 + {$else} + push rbx + push rsi + push rdi + {$ifndef AssumeMultiThreaded} + push r12 + {$endif} + push r14 + push r15 + {$endif} + +{$ifndef AssumeMultiThreaded} + xor r12, r12 + {Get the IsMultiThread variable so long} + lea rsi, [IsMultiThread] + movzx esi, byte ptr [rsi] {this also clears highest bits of the rsi register} + test esi, esi + setnz sil + shl esi, StateBitMultithreaded + or r12, rsi +{$endif} + + + {On entry: rcx = APointer; rdx = ANewSize} + {Save the original pointer in rsi} + mov rsi, rcx + {Get the block header} + mov rcx, [rcx - BlockHeaderSize] + {Is it a small block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + jnz @NotASmallBlock + {-----------------------------------Small block-------------------------------------} + {Get the block type in rbx} + mov rbx, TSmallBlockPoolHeader[rcx].BlockType + {Get the available size inside blocks of this type.} + movzx ecx, TSmallBlockType[rbx].BlockSize + sub ecx, BlockHeaderSize + {Is it an upsize or a downsize?} + cmp rcx, rdx + jb @SmallUpsize + {It's a downsize. Do we need to allocate a smaller block? Only if the new + size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder] + cmp ebx, ecx + jb @NotSmallInPlaceDownsize + {In-place downsize - return the original pointer} + mov rax, rsi + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@NotSmallInPlaceDownsize: + {Save the requested size} + mov rbx, rdx + {Allocate a smaller block} + mov rcx, rdx + call FastGetMem + {Allocated OK?} + test rax, rax + jz @Done + {$ifdef DEBUG} + test rax, AlignmentMask + jz @@OkAlignmentOnGetMem6 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem6: + {$endif} + {Move data across: count in r8} + mov r8, rbx + {Destination in edx} + mov rdx, rax + {Save the result in ebx} + mov rbx, rax + {Original pointer in ecx} + mov rcx, rsi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + call MoveX32LPUniversal + {$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} + {$endif} +{$else} + call System.Move +{$endif} + {Free the original pointer} + mov rcx, rsi + call FastFreeMem + {Return the pointer} + mov rax, rbx + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@SmallUpsize: + {State: rsi = APointer, rdx = ANewSize, rcx = Current Block Size, rbx = Current Block Type} + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes} + lea ecx, [ecx + ecx + SmallBlockUpsizeAdder] + {Save the requested size in rdi} + mov rdi, rdx + {New allocated size is the maximum of the requested size and the minimum + upsize} + xor rax, rax + sub rcx, rdx + adc rax, -1 + and rcx, rax + add rcx, rdx + {Allocate the new block} + call FastGetMem + {Allocated OK?} + test rax, rax + jz @Done + {$ifdef DEBUG} + test rax, AlignmentMask + jz @@OkAlignmentOnGetMem7 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem7: + {$endif} + {Do we need to store the requested size? Only large blocks store the + requested size.} + cmp rdi, MaximumMediumBlockSize - BlockHeaderSize + jbe @NotSmallUpsizeToLargeBlock + {Store the user requested size} + mov [rax - 2 * BlockHeaderSize], rdi + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@NotSmallUpsizeToLargeBlock: + {Get the size to move across} + movzx r8d, TSmallBlockType[rbx].BlockSize + sub r8d, BlockHeaderSize + {Move to the new block} + mov rdx, rax + {Save the result in edi} + mov rdi, rax + {Move from the old block} + mov rcx, rsi + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + call TSmallBlockType[rbx].UpsizeMoveProcedure +{$else} + call System.Move +{$endif} + {Free the old pointer} + mov rcx, rsi + call FastFreeMem + {Done} + mov rax, rdi + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@NotASmallBlock: + {Is this a medium block or a large block?} + test cl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @PossibleLargeBlock + {-------------------------------Medium block--------------------------------------} + {Status: rcx = Current Block Size + Flags, rsi = APointer, + rdx = Requested Size} + mov rbx, rcx + {Drop the flags from the header} + and ecx, DropMediumAndLargeFlagsMask + {Get a pointer to the next block in rdi} + lea rdi, [rsi + rcx] + {Subtract the block header size from the old available size} + sub ecx, BlockHeaderSize + {Get the complete flags in ebx} + and ebx, ExtractMediumAndLargeFlagsMask + {Is it an upsize or a downsize?} + cmp rdx, rcx + ja @MediumBlockUpsize + {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags, + rdi = @Next Block, rsi = APointer, rdx = Requested Size} + {Must be less than half the current size or we don't bother resizing.} + lea r15, [rdx + rdx] + cmp r15, rcx + jb @MediumMustDownsize + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumNoResize: + mov rax, rsi + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@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 + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@MediumBlockInPlaceDownsize: + {Round up to the next medium block size} + lea r15, [rdx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and r15, MediumBlockGranularityMask + add r15, MediumBlockSizeOffset + {Get the size of the second split} + add ecx, BlockHeaderSize + sub ecx, r15d + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + lea r8, IsMultiThread + cmp byte ptr [r8], False + je @DoMediumInPlaceDownsize +{$endif} +//@DoMediumLockForDownsize: + {Lock the medium blocks} +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + mov rbx, rcx // save rcx + call LockMediumBlocks + mov rcx, rbx // restore rcx +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {Reread the flags - they may have changed before medium blocks could be + locked.} + mov rbx, ExtractMediumAndLargeFlagsMask + and rbx, [rsi - BlockHeaderSize] + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DoMediumInPlaceDownsize: + {Set the new size} + or rbx, r15 + mov [rsi - BlockHeaderSize], rbx + {Get the second split size in ebx} + mov ebx, ecx + {Is the next block in use?} + mov rdx, [rdi - BlockHeaderSize] + test dl, IsFreeBlockFlag + jnz @MediumDownsizeNextBlockFree + {The next block is in use: flag its previous block as free} + or rdx, PreviousMediumBlockIsFreeFlag + mov [rdi - BlockHeaderSize], rdx + jmp @MediumDownsizeDoSplit + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumDownsizeNextBlockFree: + {The next block is free: combine it} + mov rcx, rdi + and rdx, DropMediumAndLargeFlagsMask + add rbx, rdx + add rdi, rdx + cmp edx, MinimumMediumBlockSize + jb @MediumDownsizeDoSplit + call RemoveMediumFreeBlock + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumDownsizeDoSplit: + {Store the trailing size field} + mov [rdi - 2 * BlockHeaderSize], rbx + {Store the free part's header} + lea rcx, [rbx + IsMediumBlockFlag + IsFreeBlockFlag]; + mov [rsi + r15 - BlockHeaderSize], rcx + {Bin this free block} + cmp rbx, MinimumMediumBlockSize + jb @MediumBlockDownsizeDone + lea rcx, [rsi + r15] + mov rdx, rbx + call InsertMediumBlockIntoBin + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumBlockDownsizeDone: + {Result = old pointer} + mov rax, rsi + {Unlock the medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point, since we are about to exit} + call UnlockMediumBlocks + {Result = old pointer} + mov rax, rsi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumDownsizeRealloc: + {Save the requested size} + mov rdi, rdx + mov rcx, rdx + {Allocate the new block} + call FastGetMem + test rax, rax + jz @Done + {$ifdef DEBUG} + test rax, AlignmentMask + jz @@OkAlignmentOnGetMem8 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem8: + {$endif} + {Save the result} + mov r15, rax + mov rdx, rax + mov rcx, rsi + mov r8, rdi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + call MoveX32LPUniversal + {$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} + {$endif} +{$else} + call System.Move +{$endif} + mov rcx, rsi + call FastFreeMem + {Return the result} + mov rax, r15 + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumBlockUpsize: + {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags, + rdi = @Next Block, rsi = APointer, rdx = Requested Size} + {Can we do an in-place upsize?} + mov rax, [rdi - BlockHeaderSize] + test al, IsFreeBlockFlag + jz @CannotUpsizeMediumBlockInPlace + {Get the total available size including the next block} + and rax, DropMediumAndLargeFlagsMask + {r15 = total available size including the next block (excluding the header)} + lea r15, [rax + rcx] + {Can the block fit?} + cmp rdx, r15 + ja @CannotUpsizeMediumBlockInPlace + {The next block is free and there is enough space to grow this + block in place.} +{$ifndef AssumeMultiThreaded} + lea r8, IsMultiThread + cmp byte ptr [r8], False + je @DoMediumInPlaceUpsize +{$endif} +//@DoMediumLockForUpsize: +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} + {Lock the medium blocks.} + mov rbx, rcx // save rcx + mov r15, rdx // save rdx + call LockMediumBlocks + mov rcx, rbx // restore rcx + mov rdx, r15 // restore rdx +{$else} + call AcquireSpinLockMediumBlocks +{$endif} +{$ifndef AssumeMultiThreaded} + or r12b, (UnsignedBit shl StateBitMediumLocked) +{$endif} + {Re-read the info for this block (since it may have changed before the medium + blocks could be locked)} + mov rbx, ExtractMediumAndLargeFlagsMask + and rbx, [rsi - BlockHeaderSize] + {Re-read the info for the next block} + mov rax, [rdi - BlockheaderSize] + {Next block still free?} + test al, IsFreeBlockFlag + jz @NextMediumBlockChanged + {Recalculate the next block size} + and eax, DropMediumAndLargeFlagsMask + {The available size including the next block} + lea r15, [rax + rcx] + {Can the block still fit?} + cmp rdx, r15 + ja @NextMediumBlockChanged + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@DoMediumInPlaceUpsize: + {Is the next block binnable?} + cmp eax, MinimumMediumBlockSize + {Remove the next block} + jb @MediumInPlaceNoNextRemove + mov r14, rcx + mov rcx, rdi + mov rdi, rdx + call RemoveMediumFreeBlock + mov rcx, r14 + mov rdx, rdi + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@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, MediumBlockGranularityMask + add eax, MediumBlockSizeOffset + {Calculate the size of the second split} + lea rdx, [r15 + BlockHeaderSize] + sub edx, eax + {Does it fit?} + ja @MediumInPlaceUpsizeSplit + {Grab the whole block: Mark it as used in the block following it} + and qword ptr [rsi + r15], not PreviousMediumBlockIsFreeFlag + {The block size is the full available size plus header} + add r15, BlockHeaderSize + {Upsize done} + jmp @MediumUpsizeInPlaceDone + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@MediumInPlaceUpsizeSplit: + {Store the size of the second split as the second last dword} + mov [rsi + r15 - BlockHeaderSize], rdx + {Set the second split header} + lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rsi + rax - BlockHeaderSize], rdi + mov r15, rax + cmp edx, MinimumMediumBlockSize + jb @MediumUpsizeInPlaceDone + lea rcx, [rsi + rax] + call InsertMediumBlockIntoBin + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@MediumUpsizeInPlaceDone: + {Set the size and flags for this block} + or r15, rbx + mov [rsi - BlockHeaderSize], r15 + {Result = old pointer} + mov rax, rsi + {Unlock the medium blocks} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @Done +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call destroys most of the volatile (caller-saved) registers, +(RAX, RCX, RDX, R8, R9, R10, R11), +but we don't need them at this point, since we are about to exit} + call UnlockMediumBlocks + {Result = old pointer} + mov rax, rsi +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@NextMediumBlockChanged: + {The next medium block changed while the medium blocks were being locked} +{$ifndef AssumeMultiThreaded} + test r12b, (UnsignedBit shl StateBitMediumLocked) + jz @DontUnlMedBlksAftrNxtMedBlkChg +{$endif} + +{$ifdef CheckPauseAndSwitchToThreadForAsmVersion} +{The call to "UnlockMediumBlocks" destroys most of the volatile (caller-saved) +registers (RAX, RCX, RDX, R8, R9, R10, R11), +so ew save RCX and RDX} + mov rbx, rcx // save rcx + mov r15, rdx // save rdx + call UnlockMediumBlocks + mov rcx, rbx // restore rcx + mov rdx, r15 // restore rdx +{$else} +{$ifdef InterlockedRelease} + lock +{$endif} + mov MediumBlocksLocked, cLockByteAvailable +{$endif} + + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} + +@DontUnlMedBlksAftrNxtMedBlkChg: + +@CannotUpsizeMediumBlockInPlace: + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + mov eax, ecx + shr eax, 2 + add eax, ecx + {Get the maximum of the requested size and the minimum growth size} + xor rdi, rdi + sub rax, rdx + adc rdi, -1 + and rax, rdi + add rax, rdx + {Save the size to allocate} + mov r15, rax + {Save the size to move across} + mov edi, ecx + {Save the requested size} + mov rbx, rdx + {Get the block} + mov rcx, rax + call FastGetMem + mov rdx, rbx + {Success?} + test eax, eax + jz @Done + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMem9 + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMem9: + {$endif} + {If it's a Large block - store the actual user requested size} + cmp r15, MaximumMediumBlockSize - BlockHeaderSize + jbe @MediumUpsizeNotLarge + mov [rax - 2 * BlockHeaderSize], rdx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@MediumUpsizeNotLarge: + {Save the result} + mov r15, rax + {Move the data across} + mov rdx, rax + mov rcx, rsi + mov r8, rdi +{$ifdef UseCustomVariableSizeMoveRoutines} +{$ifdef Align32Bytes} + call MoveX32LPUniversal +{$else} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} +{$endif} +{$else} + call System.Move +{$endif} + {Free the old block} + mov rcx, rsi + call FastFreeMem + {Restore the result} + mov rax, r15 + jmp @Done + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 8{$endif} +@PossibleLargeBlock: + {-----------------------Large block------------------------------} + {Is this a valid large block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + jnz @Error + mov rcx, rsi + call ReallocateLargeBlock + jmp @Done + {-----------------------Invalid block------------------------------} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Error: + xor eax, eax + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@Done: {restores registers from stack} +{$ifndef AllowAsmParams} + pop r15 + pop r14 + {$ifndef AssumeMultiThreaded} + pop r12 + {$endif} + pop rdi + pop rsi + pop rbx +{$endif} +end; +{$endif} +{$endif} +{$endif FastReallocMemNeedAssemberCode} + +{Allocates a block and fills it with zeroes} +function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc} NativeUInt{$else}Cardinal{$endif}{$endif}): Pointer; +{$ifndef ASMVersion} +{$ifdef LogLockContention} +{$ifdef FullDebugMode} +var + LCollector: PStaticCollector; +{$endif} +{$endif} +begin + {DebugAllocMem does not call FastAllocMem so in this case we can ignore returned collector.} + Result := FastGetMem(ASize{$ifdef LogLockContention}{$ifdef FullDebugMode}, LCollector{$endif}{$endif}); + {Large blocks are already zero filled} + if (Result <> nil) and (ASize <= (MaximumMediumBlockSize - BlockHeaderSize)) then + FillChar(Result^, ASize, 0); +end; +{$else} +{$ifdef 32Bit} +assembler; +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 + {$ifdef DEBUG} + test eax, AlignmentMask + jz @@OkAlignmentOnGetMemA + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMemA: + {$endif} + + {Could a block be allocated? ecx = 0 if yes, $ffffffff if no} + cmp eax, 1 + sbb ecx, ecx + {Point edx to the last dword} + lea edx, [eax + ebx] + {ebx = $ffffffff if no block could be allocated, otherwise size rounded down + to previous multiple of 4. If ebx = 0 then the block size is 1..4 bytes and + the FPU based clearing loop should not be used (since it clears 8 bytes per + iteration).} + or ebx, ecx + jz @ClearLastDWord + {Large blocks are already zero filled} + cmp ebx, MaximumMediumBlockSize - BlockHeaderSize + jae @Done + + + test FastMMCpuFeatures, FastMMCpuFeatureERMS + jz @NoERMS + + push edi + push eax + xor eax, eax + mov edi, edx + sub edi, ebx + mov ecx, ebx + cld + rep stosb + mov [edi], eax // clear last 4 bytes + pop eax + pop edi + jmp @Done + + + +@NoERMS: + {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.} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@FillLoop: + fst qword ptr [edx + ebx] + add ebx, 8 + js @FillLoop + {Clear st(0)} + ffree st(0) + {Correct the stack top} + fincstp + {Clear the last four bytes} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@ClearLastDWord: + mov [edx], ecx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Done: + pop ebx +end; + +{$else} + +{---------------64-bit BASM FastAllocMem---------------} +assembler; +asm + {Do not put ".noframe" here since it calls other functions.} + {$ifdef AllowAsmParams} + .params 1 + .pushnv rbx + {$else} + push rbx + {$endif} + {Get the size rounded down to the previous multiple of SizeOf(Pointer) into + ebx} + lea rbx, [rcx - 1] + and rbx, -8 + {Get the block} + call FastGetMem + {$ifdef DEBUG} + test rax, AlignmentMask + jz @@OkAlignmentOnGetMemB + jmp BadAlignmentOnGetMem +@@OkAlignmentOnGetMemB: + {$endif} + {Could a block be allocated? rcx = 0 if yes, -1 if no} + cmp rax, 1 + sbb rcx, rcx + {Point rdx to the last dword} + lea rdx, [rax + rbx] + {rbx = -1 if no block could be allocated, otherwise size rounded down + to previous multiple of 8. If rbx = 0 then the block size is 1..8 bytes and + the SSE2 based clearing loop should not be used (since it clears 16 bytes per + iteration).} + or rbx, rcx + jz @ClearLastQWord + {Large blocks are already zero filled} + cmp rbx, MaximumMediumBlockSize - BlockHeaderSize + jae @Done + + push rdi + push rax + xor eax, eax + mov rdi, rdx + sub rdi, rbx + mov rcx, rbx + cld + rep stosb + mov [rdi], rax // clear last 8 bytes + pop rax + pop rdi + jmp @Done + {Clear the last 8 bytes} + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@ClearLastQWord: + xor rcx, rcx + mov [rdx], rcx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Done: +{$ifndef AllowAsmParams} + pop rbx +{$endif} +end; +{$endif} +{$endif} + +{$ifdef fpc} +function FastFreeMemSize(p: pointer; size: NativeUInt):NativeUInt; +{$ifndef ASMVersion} +begin + if size=0 then + exit(0); + { can't free partial blocks, ignore size } + result := FastFreeMem(p); +{$else} +assembler; +asm + test edx, edx + jne @SizeNotZero + mov eax, 0 + jmp @Final +@SizeNotZero: + call FastFreeMem +@Final: +{$endif} +end; + +function FastMemSize(p: pointer): NativeUInt; +{$ifndef ASMVersion} +begin + Result := GetAvailableSpaceInBlock(p); +{$else} +assembler; +asm + call GetAvailableSpaceInBlock +{$endif} +end; +{$endif} + +{-----------------Post Uninstall GetMem/FreeMem/ReallocMem-------------------} + +{$ifdef DetectMMOperationsAfterUninstall} + +function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; +{$ifndef NoMessageBoxes} +var + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} +begin +{$ifdef UseOutputDebugString} + OutputDebugStringA(InvalidGetMemMsg); +{$endif} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle, Length(InvalidOperationTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0])-1)); + ShowMessageBox(InvalidGetMemMsg, LErrorMessageTitle); +{$endif} + Result := nil; +end; + +function InvalidFreeMem(APointer: Pointer): {$ifdef fpc}NativeUInt{$else}Integer{$endif}; +{$ifndef NoMessageBoxes} +var + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} +begin +{$ifdef UseOutputDebugString} + OutputDebugStringA(InvalidFreeMemMsg); +{$endif} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle, Length(InvalidOperationTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0])-1)); + ShowMessageBox(InvalidFreeMemMsg, LErrorMessageTitle); +{$endif} + Result := {$ifdef fpc}NativeUInt(-1){$else}-1{$endif}; +end; + +function InvalidReallocMem({$ifdef fpc}var {$endif}APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Integer{$endif}{$endif}): Pointer; +{$ifndef NoMessageBoxes} +var + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} +begin +{$ifdef UseOutputDebugString} + OutputDebugStringA(InvalidReallocMemMsg); +{$endif} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle, Length(InvalidOperationTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0])-1)); + ShowMessageBox(InvalidReallocMemMsg, LErrorMessageTitle); +{$endif} + Result := nil; +end; + +function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}{$ifdef fpc}NativeUInt{$else}Cardinal{$endif}{$endif}): Pointer; +{$ifndef NoMessageBoxes} +var + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} +begin +{$ifdef UseOutputDebugString} + OutputDebugStringA(InvalidAllocMemMsg); +{$endif} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(InvalidOperationTitle, LErrorMessageTitle, Length(InvalidOperationTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + ShowMessageBox(InvalidAllocMemMsg, LErrorMessageTitle); +{$endif} + Result := nil; +end; + +function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; +begin + Result := False; +end; + +{$endif} + +{------------------------EventLog handling------------------------} + +{$ifdef _EventLog} +procedure DeleteEventLog; +begin + {Delete the file} + DeleteFileA(MMLogFileName); +end; + +{Finds the start and length of the file name given a full path.} +procedure ExtractFileName(APFullPath: PAnsiChar; var APFileNameStart: PAnsiChar; var AFileNameLength: Integer); +var + LChar: AnsiChar; + LPFullPath: PAnsiChar; +begin + {Initialize} + LPFullPath := APFullPath; + APFileNameStart := LPFullPath; + AFileNameLength := 0; + {Find the file } + while True do + begin + {Get the next character} + LChar := LPFullPath^; + {End of the path string?} + if LChar = #0 then + Break; + {Advance the buffer position} + Inc(LPFullPath); + {Found a backslash? -> May be the start of the file name} + if LChar = '\' then + APFileNameStart := LPFullPath; + end; + {Calculate the length of the file name} + AFileNameLength := IntPtr(LPFullPath) - IntPtr(APFileNameStart); +end; + +procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal); +const + {Declared here, because it is not declared in the SHFolder.pas unit of some older Delphi versions.} + SHGFP_TYPE_CURRENT = 0; +var + LFileHandle: THandle; {use NativeUint if THandle is not available} + LBytesWritten: Cardinal; + LEventHeader: array[0..MaxDisplayMessageLength-1] of AnsiChar; + LAlternateLogFileName: array[0..MaxFileNameLengthDouble-1] of AnsiChar; + LPathLen, LNameLength: Integer; + LInitialPtr, LMsgPtr, LPFileName: PAnsiChar; + LInitialSize: Cardinal; + LSystemTime: TSystemTime; +begin + {Try to open the log file in read/write mode.} + LFileHandle := CreateFileA(MMLogFileName, GENERIC_READ or GENERIC_WRITE, + 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + {Did log file creation fail? If so, the destination folder is perhaps read-only: + Try to redirect logging to a file in the user's "My Documents" folder.} + if (LFileHandle = INVALID_HANDLE_VALUE) + {$ifndef MACOS} +{$ifdef Delphi4or5} + and SHGetSpecialFolderPathA(0, @(LAlternateLogFileName[0]), CSIDL_PERSONAL, True) then +{$else} + and (SHGetFolderPathA(0, CSIDL_PERSONAL or CSIDL_FLAG_CREATE, 0, + SHGFP_TYPE_CURRENT, @(LAlternateLogFileName[0])) = S_OK) then +{$endif} + {$else} + then + {$endif} + begin + {Extract the filename part from MMLogFileName and append it to the path of + the "My Documents" folder.} + LPathLen := StrLen(LAlternateLogFileName); + {Ensure that there is a trailing backslash in the path} + if (LPathLen = 0) or (LAlternateLogFileName[LPathLen - 1] <> '\') then + begin + LAlternateLogFileName[LPathLen] := '\'; + Inc(LPathLen); + end; + {Add the filename to the path} + ExtractFileName(@(MMLogFileName[0]), LPFileName, LNameLength); + System.Move(LPFileName^, LAlternateLogFileName[LPathLen], (LNameLength + 1)*SizeOf(LPFileName[0])); + {Try to open the alternate log file} + LFileHandle := CreateFileA(LAlternateLogFileName, GENERIC_READ or GENERIC_WRITE, + 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + end; + {Was the log file opened/created successfully?} + if LFileHandle <> INVALID_HANDLE_VALUE then + begin + {Seek to the end of the file} + SetFilePointer(LFileHandle, 0, nil, FILE_END); + {Set the separator} + LMsgPtr := @LEventHeader[0]; + LInitialPtr := LMsgPtr; + LInitialSize := (SizeOf(LEventHeader) div SizeOf(LEventHeader[0]))-1; + LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], Length(CRLF), (SizeOf(LEventHeader) div SizeOf(LEventHeader[0])-1)); + LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {Set the date & time} + GetLocalTime(LSystemTime); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wYear, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr^ := '/'; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMonth, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr^ := '/'; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wDay, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wHour, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr^ := ':'; + Inc(LMsgPtr); + if LSystemTime.wMinute < 10 then + begin + LMsgPtr^ := '0'; + Inc(LMsgPtr); + end; + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMinute, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr^ := ':'; + Inc(LMsgPtr); + if LSystemTime.wSecond < 10 then + begin + LMsgPtr^ := '0'; + Inc(LMsgPtr); + end; + LMsgPtr := NativeUIntToStrBuf(LSystemTime.WSecond, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {Write the header} + LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + WriteFile(LFileHandle, LEventHeader[0], NativeUInt(LMsgPtr) - NativeUInt(@LEventHeader[0]), LBytesWritten, nil); + {Write the data} + WriteFile(LFileHandle, ABuffer^, ACount, LBytesWritten, nil); + {Close the file} + CloseHandle(LFileHandle); + end; +end; + +{Sets the default log filename} +procedure SetDefaultMMLogFileName; +const + LogFileExtAnsi: PAnsiChar = LogFileExtension; +var + LEnvVarLength, LModuleNameLength: Cardinal; + LPathOverride: array[0..MaxFileNameLengthDouble-1] of AnsiChar; + LPFileName: PAnsiChar; + LFileNameLength: Integer; +begin + {Get the name of the application} + LModuleNameLength := AppendModuleFileName(@(MMLogFileName[0]), SizeOf(MMLogFileName)); + {Replace the last few characters of the module name, and optionally override + the path.} + if LModuleNameLength > 0 then + begin + {Change the filename} + System.Move(LogFileExtAnsi^, MMLogFileName[LModuleNameLength - 4], (StrLen(LogFileExtAnsi) + 1)*SizeOf(LogFileExtAnsi[0])); + {Try to read the FastMMLogFilePath environment variable} + LEnvVarLength := GetEnvironmentVariableA('FastMMLogFilePath', + @LPathOverride[0], SizeOf(LPathOverride) div SizeOf(LPathOverride[0])-1); + {Does the environment variable exist? If so, override the log file path.} + if LEnvVarLength > 0 then + begin + {Ensure that there's a trailing backslash.} + if LPathOverride[LEnvVarLength - 1] <> '\' then + begin + LPathOverride[LEnvVarLength] := '\'; + Inc(LEnvVarLength); + end; + {Add the filename to the path override} + ExtractFileName(@MMLogFileName[0], LPFileName, LFileNameLength); + System.Move(LPFileName^, LPathOverride[LEnvVarLength], (LFileNameLength + 1)*SizeOf(LPFileName[0])); + {Copy the override path back to the filename buffer} + System.Move(LPathOverride[0], MMLogFileName[0], SizeOf(MMLogFileName) - SizeOf(MMLogFileName[0])); + end; + end; +end; + +{Specify the full path and name for the filename to be used for logging memory + errors, etc. If ALogFileName is nil or points to an empty string it will + revert to the default log file name.} +procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil); +var + LLogFileNameLen: Integer; +begin + {Is ALogFileName valid?} + if (ALogFileName <> nil) and (ALogFileName^ <> #0) then + begin + LLogFileNameLen := StrLen(ALogFileName); + if LLogFileNameLen < Length(MMLogFileName) then + begin + {Set the log file name} + System.Move(ALogFileName^, MMLogFileName, (LLogFileNameLen + 1)*SizeOf(ALogFileName[0])); + Exit; + end; + end; + {Invalid log file name} + SetDefaultMMLogFileName; +end; +{$endif} + +{-----------------Full Debug Mode Memory Manager Interface--------------------} + +{$ifdef FullDebugMode} + +{Compare [AAddress], CompareVal: + If Equal: [AAddress] := NewVal and result = CompareVal + If Unequal: Result := [AAddress]} +function LockCmpxchg32(CompareVal, NewVal: Integer; AAddress: PInteger): Integer; assembler; +asm +{$ifdef 32Bit} + {On entry for 32-bit Windows: + eax = CompareVal, + edx = NewVal, + ecx = AAddress} + lock cmpxchg [ecx], edx // cmpxchg also uses EAX as an implicit operand + xor edx, edx {Clear the edx and ecx value on exit just for safety} + xor ecx, ecx +{$else} +.noframe + {On entry for 64-bit Windows: + ecx = CompareVal, + edx = NewVal, + r8 = AAddress} + mov eax, ecx // higher bits (63-32) are automatically cleared + xor ecx, ecx {Clear the ecx value on entry just for safety, after we had save the value to eax} + lock cmpxchg [r8], edx // cmpxchg also uses EAX as an implicit operand + xor edx, edx + xor r8, r8 +{$endif} +end; + +{Called by DebugGetMem, DebugFreeMem and DebugReallocMem in order to block a + free block scan operation while the memory pool is being modified.} +procedure StartChangingFullDebugModeBlock; +var + LOldCount: Integer; +begin + while True do + begin + {Get the old thread count} + LOldCount := ThreadsInFullDebugModeRoutine; + if (LOldCount >= 0) + and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then + begin + Break; + end; + {$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} + {$else} + Sleep(InitialSleepTime); + {Try again} + LOldCount := ThreadsInFullDebugModeRoutine; + if (LOldCount >= 0) + and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then + begin + Break; + end; + Sleep(AdditionalSleepTime); + {$endif} + end; +end; + +procedure DoneChangingFullDebugModeBlock; assembler; +asm +{$ifdef 32Bit} + lock dec ThreadsInFullDebugModeRoutine +{$else} +.noframe + lea rax, ThreadsInFullDebugModeRoutine + lock dec dword ptr [rax] +{$endif} +end; + +{Increments the allocation number} +procedure IncrementAllocationNumber; assembler; +asm +{$ifdef 32Bit} + lock inc CurrentAllocationNumber +{$else} +.noframe + lea rax, CurrentAllocationNumber + lock inc dword ptr [rax] +{$endif} +end; + +{Called by a routine wanting to lock the entire memory pool in FullDebugMode, e.g. before scanning the memory + pool for corruptions.} +procedure BlockFullDebugModeMMRoutines; +begin + while True do + begin + {Get the old thread count} + if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then + Break; +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} +{$else} + Sleep(InitialSleepTime); + {Try again} + if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; +end; + +procedure UnblockFullDebugModeMMRoutines; +begin + {Currently blocked? If so, unblock the FullDebugMode routines.} + if ThreadsInFullDebugModeRoutine = -1 then + ThreadsInFullDebugModeRoutine := 0; +end; + +{Returns the current "allocation group". Whenever a GetMem request is serviced + in FullDebugMode, the current "allocation group" is stored in the block header. + This may help with debugging. Note that if a block is subsequently reallocated + that it keeps its original "allocation group" and "allocation number" (all + allocations are also numbered sequentially).} +function GetCurrentAllocationGroup: Cardinal; +begin + Result := AllocationGroupStack[AllocationGroupStackTop]; +end; + +{Allocation groups work in a stack like fashion. Group numbers are pushed onto + and popped off the stack. Note that the stack size is limited, so every push + should have a matching pop.} +procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal); +begin + if AllocationGroupStackTop < AllocationGroupStackSize - 1 then + begin + Inc(AllocationGroupStackTop); + AllocationGroupStack[AllocationGroupStackTop] := ANewCurrentAllocationGroup; + end + else + begin + {Raise a runtime error if the stack overflows} + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +end; + +procedure PopAllocationGroup; +begin + if AllocationGroupStackTop > 0 then + begin + Dec(AllocationGroupStackTop); + end + else + begin + {Raise a runtime error if the stack underflows} + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +end; + +{Sums all the dwords starting at the given address. ACount must be > 0 and a + multiple of SizeOf(Pointer).} +function SumNativeUInts(AStartValue: NativeUInt; APointer: PNativeUInt; + ACount: NativeUInt): NativeUInt; assembler; +asm +{$ifdef 32Bit} + {On entry: eax = AStartValue, edx = APointer; ecx = ACount} + add edx, ecx + neg ecx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@AddLoop: + add eax, [edx + ecx] + add ecx, 4 + js @AddLoop +{$else} + .noframe + {On entry: rcx = AStartValue, rdx = APointer; r8 = ACount} + add rdx, r8 + neg r8 + mov rax, rcx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@AddLoop: + add rax, [rdx + r8] + add r8, 8 + js @AddLoop +{$endif} +end; + +{Checks the memory starting at the given address for the fill pattern. + Returns True if all bytes are all valid. ACount must be >0 and a multiple of + SizeOf(Pointer).} +function CheckFillPattern(APointer: Pointer; ACount: NativeUInt; + AFillPattern: NativeUInt): Boolean; assembler; +asm +{$ifdef 32Bit} + {On entry: eax = APointer; edx = ACount; ecx = AFillPattern} + add eax, edx + neg edx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@CheckLoop: + cmp [eax + edx], ecx + jne @Done + add edx, 4 + js @CheckLoop +@Done: + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} + sete al +{$else} + {On entry: rcx = APointer; rdx = ACount; r8 = AFillPattern} + .noframe + add rcx, rdx + neg rdx + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 16{$endif} +@CheckLoop: + cmp [rcx + rdx], r8 + jne @Done + add rdx, 8 + js @CheckLoop + {$ifdef AsmCodeAlign}{$ifdef AsmAlNoDot}align{$else}.align{$endif} 4{$endif} +@Done: + sete al +{$endif} +end; + +{Calculates the checksum for the debug header. Adds all dwords in the debug + header to the start address of the block.} +function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): NativeUInt; +begin + Result := SumNativeUInts( + NativeUInt(APointer), + PNativeUInt(PByte(APointer) + 2 * SizeOf(Pointer)), + SizeOf(TFullDebugBlockHeader) - 2 * SizeOf(Pointer) - SizeOf(NativeUInt)); +end; + +procedure UpdateHeaderAndFooterCheckSums(APointer: PFullDebugBlockHeader); +var + LHeaderCheckSum: NativeUInt; +begin + LHeaderCheckSum := CalculateHeaderCheckSum(APointer); + APointer.HeaderCheckSum := LHeaderCheckSum; + PNativeUInt(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum; +end; + +function LogCurrentThreadAndStackTrace(ASkipFrames: Cardinal; ABuffer: PAnsiChar; ABufferLengthChars: Cardinal): PAnsiChar; +var + LCurrentStackTrace: TStackTrace; + LInitialBufPtr: PAnsiChar; + LDiff, LInitialLengthChars, LC: NativeUInt; + LBufferLengthChars: Cardinal; + L: Integer; +begin + LBufferLengthChars := ABufferLengthChars; + {Get the current call stack} + GetStackTrace(@LCurrentStackTrace[0], StackTraceDepth, ASkipFrames); + {Log the thread ID} + Result := ABuffer; + L := Length(CurrentThreadIDMsg); + if (L > 0) then + begin + LC := L; + if LC < LBufferLengthChars then + begin + Result := AppendStringToBuffer(CurrentThreadIDMsg, ABuffer, Length(CurrentThreadIDMsg), LBufferLengthChars); + Dec(LBufferLengthChars, Length(CurrentThreadIDMsg)); + LInitialBufPtr := Result; + LInitialLengthChars := LBufferLengthChars; + Result := NativeUIntToHexBuf(GetThreadID, Result, LInitialLengthChars-NativeUInt(LInitialBufPtr-Result)); + {List the stack trace} + if LInitialBufPtr >= Result then + begin + LDiff := LInitialBufPtr-Result; + if LDiff <= LInitialLengthChars then + begin + Result := AppendStringToBuffer(CurrentStackTraceMsg, Result, Length(CurrentStackTraceMsg), LInitialLengthChars-LDiff); + if LInitialBufPtr >= Result then + begin + LDiff := LInitialBufPtr-Result; + if LDiff <= LInitialLengthChars then + begin + Result := LogStackTrace(@LCurrentStackTrace[0], StackTraceDepth, Result); + end; + end; + end; + end; + end; + end; +end; + +{$ifndef DisableLoggingOfMemoryDumps} +function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar; ABufSize: Cardinal): PAnsiChar; +var + LByteNum, LVal: Cardinal; + LDataPtr: PByte; +begin + Result := AppendStringToBuffer(MemoryDumpMsg, ABuffer, Length(MemoryDumpMsg), ABufSize); + {todo: Implement ABufSize checking and in this function} + Result := NativeUIntToHexBuf(NativeUInt(APointer) + SizeOf(TFullDebugBlockHeader), Result, ABufSize{todo}); + Result^ := ':'; + Inc(Result); + {Add the bytes} + LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader)); + for LByteNum := 0 to 255 do + begin + if (LByteNum and 31) = 0 then + begin + Result^ := #13; + Inc(Result); + Result^ := #10; + Inc(Result); + end + else + begin + Result^ := ' '; + Inc(Result); + end; + {Set the hex data} + LVal := Byte(LDataPtr^); + Result^ := HexTable[LVal shr 4]; + Inc(Result); + Result^ := HexTable[LVal and $f]; + Inc(Result); + {Next byte} + Inc(LDataPtr); + end; + {Dump ASCII} + LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader)); + for LByteNum := 0 to 255 do + begin + if (LByteNum and 31) = 0 then + begin + Result^ := #13; + Inc(Result); + Result^ := #10; + Inc(Result); + end + else + begin + Result^ := ' '; + Inc(Result); + Result^ := ' '; + Inc(Result); + end; + {Set the hex data} + LVal := Byte(LDataPtr^); + if LVal < 32 then + Result^ := '.' + else + Result^ := AnsiChar(LVal); + Inc(Result); + {Next byte} + Inc(LDataPtr); + end; +end; +{$endif} + +{Rotates AValue ABitCount bits to the right} +function RotateRight(AValue, ABitCount: NativeUInt): NativeUInt; assembler; +asm +{$ifdef 32Bit} + mov ecx, edx + ror eax, cl +{$else} + .noframe + mov rax, rcx + mov rcx, rdx + ror rax, cl +{$endif} +end; + +{Determines whether a byte in the user portion of the freed block has been modified. Does not work beyond + the end of the user portion (i.e. footer and beyond).} +function FreeBlockByteWasModified(APointer: PFullDebugBlockHeader; AUserOffset: NativeUInt): Boolean; +var + LFillPattern: NativeUInt; +begin + {Get the expected fill pattern} + if AUserOffset < SizeOf(Pointer) then + begin + LFillPattern := NativeUInt(@FreedObjectVMT.VMTMethods[0]); + end + else + begin +{$ifndef CatchUseOfFreedInterfaces} + LFillPattern := DebugFillPattern; +{$else} + LFillPattern := NativeUInt(@VMTBadInterface); +{$endif} + end; + {Compare the byte value} + Result := Byte(PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + AUserOffset)^) <> + Byte(RotateRight(LFillPattern, (AUserOffset and (SizeOf(Pointer) - 1)) * 8)); +end; + +function LogBlockChanges(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar; ABufSize: Cardinal): PAnsiChar; +const + CMaxLogChanges = 32; {Log a maximum of 32 changes} +var + LOffset, LChangeStart, LCount: NativeUInt; + LLogCount: Integer; + LBuffer: PAnsiChar; +begin + LBuffer := ABuffer; + {No errors logged so far} + LLogCount := 0; + LOffset := 0; + while (LOffset < APointer.UserSize) and (LLogCount < CMaxLogChanges) do + begin + {Has the byte been modified?} + if FreeBlockByteWasModified(APointer, LOffset) then + begin + {Found the start of a changed block, now find the length} + LChangeStart := LOffset; + LCount := 0; + while True do + begin + Inc(LCount); + Inc(LOffset); + if (LOffset >= APointer.UserSize) + or (not FreeBlockByteWasModified(APointer, LOffset)) then + begin + Break; + end; + end; + {Got the offset and length, now log it.} + if LLogCount = 0 then + begin + LBuffer := AppendStringToBuffer(FreeModifiedDetailMsg, LBuffer, Length(FreeModifiedDetailMsg), ABufSize{todo: Implement ABufSize checking and in this function}); + end + else + begin + LBuffer^ := ','; + Inc(LBuffer);{todo: implement buffer size checking} + LBuffer^ := ' '; + Inc(LBuffer);{todo: ibidem} + end; + LBuffer := NativeUIntToStrBuf(LChangeStart, LBuffer, ABufSize{todo: ibidem}); + LBuffer^ := '('; + Inc(LBuffer); + LBuffer := NativeUIntToStrBuf(LCount, LBuffer, ABufSize{todo: ibidem}); + LBuffer^ := ')'; + Inc(LBuffer); + {Increment the log count} + Inc(LLogCount); + end; + {Next byte} + Inc(LOffset); + end; + {Return the current buffer position} + Result := LBuffer; +end; + +function LogStackTraceSafe(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; ABuffer: PAnsiChar; ADestinationBufferLengthChars: Cardinal): PAnsiChar; +begin + {todo: implement the ADestinationBufferLengthChars chandling} + Result := LogStackTrace(AReturnAddresses, AMaxDepth, ABuffer); +end; + + +procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation; LHeaderValid, LFooterValid: Boolean); +var + LInitialPtr, LMsgPtr: PAnsiChar; + LErrorMessage: array[0..MaxLogMessageLength-1] of AnsiChar; +{$ifndef NoMessageBoxes} + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} + LClass: TClass; + {$ifdef CheckCppObjectTypeEnabled} + LCppObjectTypeName: PAnsiChar; + {$endif} + LInitialSize, Left: Cardinal; +begin + {Display the error header and the operation type.} + LMsgPtr := @(LErrorMessage[0]); + LInitialPtr := LMsgPtr; + LInitialSize := (SizeOf(LErrorMessage) div SizeOf(LErrorMessage[0]))-1; + LMsgPtr := AppendStringToBuffer(ErrorMsgHeader, LMsgPtr, Length(ErrorMsgHeader), LInitialSize); + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + case AOperation of + boGetMem: LMsgPtr := AppendStringToBuffer(GetMemMsg, LMsgPtr, Length(GetMemMsg), Left); + boFreeMem: LMsgPtr := AppendStringToBuffer(FreeMemMsg, LMsgPtr, Length(FreeMemMsg), Left); + boReallocMem: LMsgPtr := AppendStringToBuffer(ReallocMemMsg, LMsgPtr, Length(ReallocMemMsg), Left); + boBlockCheck: LMsgPtr := AppendStringToBuffer(BlockCheckMsg, LMsgPtr, Length(BlockCheckMsg), Left); + end; + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(OperationMsg, LMsgPtr, Length(OperationMsg), Left); + {Is the header still intact?} + if LHeaderValid then + begin + {Is the footer still valid?} + if LFooterValid then + begin + {A freed block has been modified, a double free has occurred, or an + attempt was made to free a memory block allocated by a different + instance of FastMM.} + if AOperation <= boGetMem then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg), Left); + + {Log the exact changes that caused the error.} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := LogBlockChanges(APointer, LMsgPtr, Left); + end + else + begin + {It is either a double free, or an attempt was made to free a block + that was allocated via a different memory manager.} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + + if APointer.AllocatedByRoutine = nil then + LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg), Left) + else + LMsgPtr := AppendStringToBuffer(WrongMMFreeErrorMsg, LMsgPtr, Length(WrongMMFreeErrorMsg), Left); + end; + end + else + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(BlockFooterCorruptedMsg, LMsgPtr, Length(BlockFooterCorruptedMsg), Left) + end; + {Set the block size message} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + if AOperation <= boGetMem then + LMsgPtr := AppendStringToBuffer(PreviousBlockSizeMsg, LMsgPtr, Length(PreviousBlockSizeMsg), Left) + else + LMsgPtr := AppendStringToBuffer(CurrentBlockSizeMsg, LMsgPtr, Length(CurrentBlockSizeMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.UserSize, LMsgPtr, Left); + {The header is still intact - display info about the this/previous allocation} + if APointer.AllocationStackTrace[0] <> 0 then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + if AOperation <= boGetMem then + LMsgPtr := AppendStringToBuffer(ThreadIDPrevAllocMsg, LMsgPtr, Length(ThreadIDPrevAllocMsg), Left) + else + LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr, Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg), Left); + + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := LogStackTraceSafe(@APointer.AllocationStackTrace[0], StackTraceDepth, LMsgPtr, Left); + end; + {Get the class this block was used for previously} + LClass := DetectClassInstance(@APointer.PreviouslyUsedByClass); + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr, Left); + end; + {$ifdef CheckCppObjectTypeEnabled} + if (LClass = nil) and Assigned(GetCppVirtObjTypeNameByVTablePtrFunc) then + begin + LCppObjectTypeName := GetCppVirtObjTypeNameByVTablePtrFunc(Pointer(APointer.PreviouslyUsedByClass), 0); + if Assigned(LCppObjectTypeName) then + begin + LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg)); + LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName)); + end; + end; + {$endif} + {Get the current class for this block} + if (AOperation > boGetMem) and (APointer.AllocatedByRoutine <> nil) then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg), Left); + LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader))); + if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then + LClass := nil; + {$ifndef CheckCppObjectTypeEnabled} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr, Left); + {$else} + if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then + begin + LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), + APointer.UserSize); + if LCppObjectTypeName <> nil then + LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName)) + else + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); + end + else + begin + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); + end; + {$endif} + {Log the allocation group} + if APointer.AllocationGroup > 0 then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr, Left); + end; + {Log the allocation number} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr, Left); + end + else + begin + {Log the allocation group} + if APointer.AllocationGroup > 0 then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr, Left); + end; + {Log the allocation number} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg), Left); + + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr, Left); + end; + {Get the call stack for the previous free} + if APointer.FreeStackTrace[0] <> 0 then + begin + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(ThreadIDAtFreeMsg, LMsgPtr, Length(ThreadIDAtFreeMsg), Left); + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := NativeUIntToHexBuf(APointer.FreedByThread, LMsgPtr, Left); + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg), Left); + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := LogStackTraceSafe(@APointer.FreeStackTrace[0], StackTraceDepth, LMsgPtr, Left); + end; + end + else + begin + {Header has been corrupted} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg), Left); + end; + {Add the current stack trace} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := LogCurrentThreadAndStackTrace(3 + Ord(AOperation <> boGetMem) + Ord(AOperation = boReallocMem), LMsgPtr, Left); +{$ifndef DisableLoggingOfMemoryDumps} + {Add the memory dump} + Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); + LMsgPtr := LogMemoryDump(APointer, LMsgPtr, Left); +{$endif} + + {Trailing CRLF} + if Left > 2 then + begin + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + end; + // Left := LInitialSize-NativeUint(LMsgPtr-LInitialPtr); {this assignment produces a compiler "hint", but might have been useful for further development} + + {Trailing #0} + LMsgPtr^ := #0; +{$ifdef LogErrorsToFile} + {Log the error} + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); +{$endif} +{$ifdef UseOutputDebugString} + OutputDebugStringA(LErrorMessage); +{$endif} + {Show the message} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle, Length(BlockErrorMsgTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + ShowMessageBox(LErrorMessage, LErrorMessageTitle); +{$endif} +end; + +{Logs the stack traces for a memory leak to file} +procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak: Boolean); +var + LHeaderValid: Boolean; + LInitialPtr, LMsgPtr: PAnsiChar; + LErrorMessage: array[0..MaxLogMessageLength-1] of AnsiChar; + LClass: TClass; + {$ifdef CheckCppObjectTypeEnabled} + LCppObjectTypeName: PAnsiChar; + {$endif} + LInitialSize: Cardinal; +begin + {Display the error header and the operation type.} + + LMsgPtr := @LErrorMessage[0]; + LInitialPtr := LMsgPtr; + LInitialSize := (SizeOf(LErrorMessage) div SizeOf(LErrorMessage[0]))-1; + + if IsALeak then + LMsgPtr := AppendStringToBuffer(LeakLogHeader, LMsgPtr, Length(LeakLogHeader), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)) + else + LMsgPtr := AppendStringToBuffer(BlockScanLogHeader, LMsgPtr, Length(BlockScanLogHeader), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {Is the debug info surrounding the block valid?} + LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum; + {Is the header still intact?} + if LHeaderValid then + begin + {The header is still intact - display info about this/previous allocation} + if APointer.AllocationStackTrace[0] <> 0 then + begin + LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := LogStackTrace(@(APointer.AllocationStackTrace[0]), StackTraceDepth, LMsgPtr {, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)}{todo: Implement}); + end; + LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {Get the current class for this block} + LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader))); + if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then + LClass := nil; + {$ifndef CheckCppObjectTypeEnabled} + if LClass <> nil then + begin + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end + else + begin + case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of + stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + end; + {$else} + if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then + begin + LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), + APointer.UserSize); + if LCppObjectTypeName <> nil then + LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName)) + else + begin + case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of + stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr); + stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage)); + stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage)); + end; + end; + end + else + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); + {$endif} + {Log the allocation group} + if APointer.AllocationGroup > 0 then + begin + LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Log the allocation number} + LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end + else + begin + {Header has been corrupted} + if LInitialSize-NativeUint(LMsgPtr-LInitialPtr) > 3 then + begin + LMsgPtr^ := '.'; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + end; +{$ifndef DisableLoggingOfMemoryDumps} + {Add the memory dump} + LMsgPtr := LogMemoryDump(APointer, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); +{$endif} + {Trailing CRLF} + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + {Trailing #0} + LMsgPtr^ := #0; + {Log the error} + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); +end; + +{Checks that a free block is unmodified} +function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: NativeUInt; + AOperation: TBlockOperation): Boolean; +var + LHeaderCheckSum: NativeUInt; + LHeaderValid, LFooterValid, LBlockUnmodified: Boolean; +begin + LHeaderCheckSum := CalculateHeaderCheckSum(APBlock); + LHeaderValid := LHeaderCheckSum = APBlock.HeaderCheckSum; + {Is the footer itself still in place} + LFooterValid := LHeaderValid + and (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ = (not LHeaderCheckSum)); + {Is the footer and debug VMT in place? The debug VMT is only valid if the user size is greater than the size of a pointer.} + if LFooterValid + and (APBlock.UserSize < SizeOf(Pointer)) or (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader))^ = NativeUInt(@FreedObjectVMT.VMTMethods[0])) then + begin + {Store the debug fill pattern in place of the footer in order to simplify + checking for block modifications.} + PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := + {$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern; + {$else} + RotateRight(NativeUInt(@VMTBadInterface), (APBlock.UserSize and (SizeOf(Pointer) - 1)) * 8); + {$endif} + {Check that all the filler bytes are valid inside the block, except for + the "dummy" class header} + LBlockUnmodified := CheckFillPattern(PNativeUInt(PByte(APBlock) + (SizeOf(TFullDebugBlockHeader) + SizeOf(Pointer))), + ABlockSize - (FullDebugBlockOverhead + SizeOf(Pointer)), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {Reset the old footer} + PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := not LHeaderCheckSum; + end + else + LBlockUnmodified := False; + if (not LHeaderValid) or (not LFooterValid) or (not LBlockUnmodified) then + begin + LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid); + Result := False; + end + else + Result := True; +end; + +function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +{$ifdef LogLockContention} +var + LCollector: PStaticCollector; + LStackTrace: TStackTrace; +{$endif} +begin + {Scan the entire memory pool first?} + if FullDebugModeScanMemoryPoolBeforeEveryOperation then + ScanMemoryPoolForCorruptions; + {Enter the memory manager: block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {We need extra space for (a) The debug header, (b) the block debug trailer + and (c) the trailing block size pointer for free blocks} + Result := FastGetMem(ASize + FullDebugBlockOverhead {$ifdef LogLockContention}, LCollector{$endif}); + if Result <> nil then + begin + {Large blocks are always newly allocated (and never reused), so checking + for a modify-after-free is not necessary.} + if (ASize > (MaximumMediumBlockSize - BlockHeaderSize - FullDebugBlockOverhead)) + or CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + BlockHeaderSize, boGetMem) then + begin + {Set the allocation call stack} + GetStackTrace(@(PFullDebugBlockHeader(Result).AllocationStackTrace[0]), StackTraceDepth, 1); +{$ifdef LogLockContention} + if assigned(LCollector) then + LCollector.Add(@PFullDebugBlockHeader(Result).AllocationStackTrace[0], StackTraceDepth); +{$endif LogLockContention} + {Set the thread ID of the thread that allocated the block} + PFullDebugBlockHeader(Result).AllocatedByThread := GetThreadID; + {Block is now in use: It was allocated by this routine} + PFullDebugBlockHeader(Result).AllocatedByRoutine := @DebugGetMem; + {Set the group number} + PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop]; + {Set the allocation number} + IncrementAllocationNumber; + PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber; + {Clear the previous block trailer} + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ := + {$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern; + {$else} + RotateRight(NativeUInt(@VMTBadInterface), (PFullDebugBlockHeader(Result).UserSize and (SizeOf(Pointer) - 1)) * 8); + {$endif} + {Set the user size for the block} + PFullDebugBlockHeader(Result).UserSize := ASize; + {Set the checksums} + UpdateHeaderAndFooterCheckSums(Result); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugGetMemFinish) then + OnDebugGetMemFinish(PFullDebugBlockHeader(Result), ASize); + {$endif} + {Return the start of the actual block} + Result := Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader)); +{$ifdef EnableMemoryLeakReporting} + {Should this block be marked as an expected leak automatically?} + if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then + RegisterExpectedMemoryLeak(Result); +{$endif} + end + else + begin +{$ifdef LogLockContention} + if assigned(LCollector) then + begin + GetStackTrace(@LStackTrace, StackTraceDepth, 1); + LCollector.Add(@(LStackTrace[0]), StackTraceDepth); + end; +{$endif LogLockContention} + Result := nil; + end; + end + else + begin + {The process ran out of address space: Release the address space slack so that some subsequent GetMem calls will + succeed in order for any error logging, etc. to complete successfully.} + if AddressSpaceSlackPtr <> nil then + begin + VirtualFree(AddressSpaceSlackPtr, 0, MEM_RELEASE); + AddressSpaceSlackPtr := nil; + end; + end; + finally + {Leaving the memory manager routine: Block scans may be performed again.} + DoneChangingFullDebugModeBlock; + end; +end; + +function CheckBlockBeforeFreeOrRealloc(APBlock: PFullDebugBlockHeader; + AOperation: TBlockOperation): Boolean; +var + LHeaderValid, LFooterValid: Boolean; + LPFooter: PNativeUInt; +{$ifndef CatchUseOfFreedInterfaces} + LBlockSize: NativeUInt; + LPTrailingByte, LPFillPatternEnd: PByte; +{$endif} +begin + {Is the checksum for the block header valid?} + LHeaderValid := CalculateHeaderCheckSum(APBlock) = APBlock.HeaderCheckSum; + {If the header is corrupted then the footer is assumed to be corrupt too.} + if LHeaderValid then + begin + {Check the footer checksum: The footer checksum should equal the header + checksum with all bits inverted.} + LPFooter := PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize); + if APBlock.HeaderCheckSum = (not (LPFooter^)) then + begin + LFooterValid := True; +{$ifndef CatchUseOfFreedInterfaces} + {Large blocks do not have the debug fill pattern, since they are never reused.} + if PNativeUInt(PByte(APBlock) - BlockHeaderSize)^ and (IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then + begin + {Check that the application has not modified bytes beyond the block + footer. The $80 fill pattern should extend up to 2 nativeints before + the start of the next block (leaving space for the free block size and + next block header.)} + LBlockSize := GetAvailableSpaceInBlock(APBlock); + LPFillPatternEnd := PByte(PByte(APBlock) + LBlockSize - SizeOf(Pointer)); + LPTrailingByte := PByte(PByte(LPFooter) + SizeOf(NativeUInt)); + while UIntPtr(LPTrailingByte) < UIntPtr(LPFillPatternEnd) do + begin + if Byte(LPTrailingByte^) <> DebugFillByte then + begin + LFooterValid := False; + Break; + end; + Inc(LPTrailingByte); + end; + end; +{$endif} + end + else + LFooterValid := False; + end + else + LFooterValid := False; + {The header and footer must be intact and the block must have been allocated + by this memory manager instance.} + if LFooterValid and (APBlock.AllocatedByRoutine = @DebugGetMem) then + begin + Result := True; + end + else + begin + {Log the error} + LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid); + {Return an error} + Result := False; + end; +end; + +function DebugFreeMem(APointer: Pointer): Integer; +var + LActualBlock: PFullDebugBlockHeader; + LBlockHeader: NativeUInt; +begin + {Scan the entire memory pool first?} + if FullDebugModeScanMemoryPoolBeforeEveryOperation then + ScanMemoryPoolForCorruptions; + {Get a pointer to the start of the actual block} + LActualBlock := PFullDebugBlockHeader(PByte(APointer) + - SizeOf(TFullDebugBlockHeader)); + {Is the debug info surrounding the block valid?} + if CheckBlockBeforeFreeOrRealloc(LActualBlock, boFreeMem) then + begin + {Enter the memory manager: block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugFreeMemStart) then + OnDebugFreeMemStart(LActualBlock); + {$endif} + {Large blocks are never reused, so there is no point in updating their + headers and fill pattern.} + LBlockHeader := PNativeUInt(PByte(LActualBlock) - BlockHeaderSize)^; + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then + begin + {Get the class the block was used for} + LActualBlock.PreviouslyUsedByClass := PNativeUInt(APointer)^; + {Set the free call stack} + GetStackTrace(@LActualBlock.FreeStackTrace[0], StackTraceDepth, 1); + {Set the thread ID of the thread that freed the block} + LActualBlock.FreedByThread := GetThreadID; + {Block is now free} + LActualBlock.AllocatedByRoutine := nil; + {Clear the user area of the block} + DebugFillMem(APointer^, LActualBlock.UserSize, + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {Set a pointer to the dummy VMT} + PNativeUInt(APointer)^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]); + {Recalculate the checksums} + UpdateHeaderAndFooterCheckSums(LActualBlock); + end; +{$ifdef EnableMemoryLeakReporting} + {Automatically deregister the expected memory leak?} + if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then + UnregisterExpectedMemoryLeak(APointer); +{$endif} + {Free the actual block} + Result := FastFreeMem(LActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugFreeMemFinish) then + OnDebugFreeMemFinish(LActualBlock, Result); + {$endif} + finally + {Leaving the memory manager routine: Block scans may be performed again.} + DoneChangingFullDebugModeBlock; + end; + end + else + begin +{$ifdef SuppressFreeMemErrorsInsideException} + if {$ifdef BDS2006AndUp}ExceptObject{$else}RaiseList{$endif} <> nil then + Result := 0 + else +{$endif} + Result := -1; + end; +end; + +function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +var + LMoveSize, LBlockSpace: NativeUInt; + LActualBlock, LNewActualBlock: PFullDebugBlockHeader; +begin + {Scan the entire memory pool first?} + if FullDebugModeScanMemoryPoolBeforeEveryOperation then + ScanMemoryPoolForCorruptions; + {Get a pointer to the start of the actual block} + LActualBlock := PFullDebugBlockHeader(PByte(APointer) + - SizeOf(TFullDebugBlockHeader)); + {Is the debug info surrounding the block valid?} + if CheckBlockBeforeFreeOrRealloc(LActualBlock, boReallocMem) then + begin + {Get the current block size} + LBlockSpace := GetAvailableSpaceInBlock(LActualBlock); + {Can the block fit? We need space for the debug overhead and the block header + of the next block} + if LBlockSpace < (NativeUInt(ANewSize) + FullDebugBlockOverhead) then + begin + {Get a new block of the requested size.} + Result := DebugGetMem(ANewSize); + if Result <> nil then + begin + {Block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemStart) then + OnDebugReallocMemStart(LActualBlock, ANewSize); + {$endif} + {We reuse the old allocation number. Since DebugGetMem always bumps + CurrentAllocationGroup, there may be gaps in the sequence of + allocation numbers.} + LNewActualBlock := PFullDebugBlockHeader(PByte(Result) + - SizeOf(TFullDebugBlockHeader)); + LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup; + LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber; + {Recalculate the header and footer checksums} + UpdateHeaderAndFooterCheckSums(LNewActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemFinish) then + OnDebugReallocMemFinish(LNewActualBlock, ANewSize); + {$endif} + finally + {Block scans can again be performed safely} + DoneChangingFullDebugModeBlock; + end; + {How many bytes to move?} + LMoveSize := LActualBlock.UserSize; + if LMoveSize > NativeUInt(ANewSize) then + LMoveSize := ANewSize; + {Move the data across} + System.Move(APointer^, Result^, LMoveSize); + {Free the old block} + DebugFreeMem(APointer); + end + else + begin + Result := nil; + end; + end + else + begin + {Block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemStart) then + OnDebugReallocMemStart(LActualBlock, ANewSize); + {$endif} + {Clear all data after the new end of the block up to the old end of the + block, including the trailer.} + DebugFillMem(Pointer(PByte(APointer) + NativeUInt(ANewSize) + SizeOf(NativeUInt))^, + NativeInt(LActualBlock.UserSize) - ANewSize, +{$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern); +{$else} + RotateRight(NativeUInt(@VMTBadInterface), (ANewSize and (SizeOf(Pointer) - 1)) * 8)); +{$endif} + {Update the user size} + LActualBlock.UserSize := ANewSize; + {Set the new checksums} + UpdateHeaderAndFooterCheckSums(LActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemFinish) then + OnDebugReallocMemFinish(LActualBlock, ANewSize); + {$endif} + finally + {Block scans can again be performed safely} + DoneChangingFullDebugModeBlock; + end; + {Return the old pointer} + Result := APointer; + end; + end + else + begin + Result := nil; + end; +end; + +{Allocates a block and fills it with zeroes} +function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; +begin + Result := DebugGetMem(ASize); + {Clear the block} + if Result <> nil then + FillChar(Result^, ASize, 0); +end; + +{Raises a runtime error if a memory corruption was encountered. Subroutine for + InternalScanMemoryPool and InternalScanSmallBlockPool.} +procedure RaiseMemoryCorruptionError; +begin + {Disable exhaustive checking in order to prevent recursive exceptions.} + FullDebugModeScanMemoryPoolBeforeEveryOperation := False; + {Unblock the memory manager in case the creation of the exception below + causes an attempt to be made to allocate memory.} + UnblockFullDebugModeMMRoutines; + {Raise the runtime error} +{$ifdef BCB6OrDelphi7AndUp} + System.Error(reOutOfMemory); +{$else} + System.RunError(reOutOfMemory); +{$endif} +end; + +{Subroutine for InternalScanMemoryPool: Checks the given small block pool for + allocated blocks} +procedure InternalScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader; + AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal); +var + LCurPtr, LEndPtr: Pointer; +begin + {Get the first and last pointer for the pool} + GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr); + {Step through all blocks} + while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do + begin + {Is this block in use? If so, is the debug info intact?} + if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then + begin + if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then + begin + if (PFullDebugBlockHeader(LCurPtr).AllocationGroup >= AFirstAllocationGroupToLog) + and (PFullDebugBlockHeader(LCurPtr).AllocationGroup <= ALastAllocationGroupToLog) then + begin + LogMemoryLeakOrAllocatedBlock(LCurPtr, False); + end; + end + else + RaiseMemoryCorruptionError; + end + else + begin + {Check that the block has not been modified since being freed} + if not CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck) then + RaiseMemoryCorruptionError; + end; + {Next block} + Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize); + end; +end; + +{Subroutine for LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions: + Scans the memory pool for corruptions and optionally logs allocated blocks + in the allocation group range.} +procedure InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal); +var + LPLargeBlock: PLargeBlockHeader; + LPMediumBlock: Pointer; + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LMediumBlockHeader: NativeUInt; +begin + {Block all the memory manager routines while performing the scan. No memory + block may be allocated or freed, and no FullDebugMode block header or + footer may be modified, while the scan is in progress.} + BlockFullDebugModeMMRoutines; + try + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Is the block in use?} + if LMediumBlockHeader and IsFreeBlockFlag = 0 then + begin + {Block is in use: Is it a medium block or small block pool?} + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get all the leaks for the small block pool} + InternalScanSmallBlockPool(LPMediumBlock, AFirstAllocationGroupToLog, ALastAllocationGroupToLog); + end + else + begin + if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) then + begin + if (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog) + and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then + begin + LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False); + end; + end + else + RaiseMemoryCorruptionError; + end; + end + else + begin + {Check that the block has not been modified since being freed} + if not CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck) then + RaiseMemoryCorruptionError; + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader^.NextMediumBlockPoolHeader; + end; + {Scan large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + if CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) then + begin + if (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog) + and (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then + begin + LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), False); + end; + end + else + RaiseMemoryCorruptionError; + {Get the next large block} + LPLargeBlock := LPLargeBlock^.NextLargeBlockHeader; + end; + finally + {Unblock the FullDebugMode memory manager routines.} + UnblockFullDebugModeMMRoutines; + end; +end; + +{Logs detail about currently allocated memory blocks for the specified range of + allocation groups. if ALastAllocationGroupToLog is less than + AFirstAllocationGroupToLog or it is zero, then all allocation groups are + logged. This routine also checks the memory pool for consistency at the same + time, raising an "Out of Memory" error if the check fails.} +procedure LogAllocatedBlocksToFile(AFirstAllocationGroupToLog, ALastAllocationGroupToLog: Cardinal); +var + LFirstAllocationGroupToLog, LLastAllocationGroupToLog: Cardinal; +begin + LFirstAllocationGroupToLog := AFirstAllocationGroupToLog; + LLastAllocationGroupToLog := ALastAllocationGroupToLog; + {Validate input} + if (LLastAllocationGroupToLog = 0) or (LLastAllocationGroupToLog < LFirstAllocationGroupToLog) then + begin + {Bad input: log all groups} + LFirstAllocationGroupToLog := 0; + LLastAllocationGroupToLog := $ffffffff; + end; + {Scan the memory pool, logging allocated blocks in the requested range.} + InternalScanMemoryPool(LFirstAllocationGroupToLog, LLastAllocationGroupToLog); +end; + +{Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is + raised.} +procedure ScanMemoryPoolForCorruptions; +begin + {Scan the memory pool for corruptions, but don't log any allocated blocks} + InternalScanMemoryPool($ffffffff, 0); +end; + +{-----------------------Invalid Virtual Method Calls-------------------------} + +{ TFreedObject } + +{Used to determine the index of the virtual method call on the freed object. + Do not change this without updating MaxFakeVMTEntries. Currently 200.} +procedure TFreedObject.GetVirtualMethodIndex; assembler; +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; + LInitialPtr, LMsgPtr: PAnsiChar; + LErrorMessage: array[0..MaxLogMessageLength-1] of AnsiChar; +{$ifndef NoMessageBoxes} + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} + LClass: TClass; + LActualBlock: PFullDebugBlockHeader; + LInitialSize: Cardinal; + LSelfPtr: Pointer; +begin + {Get the offset of the virtual method} + LVMOffset := (MaxFakeVMTEntries - VMIndex) * SizeOf(Pointer) + vmtParent + SizeOf(Pointer); + {Reset the index for the next error} + VMIndex := 0; + {Get the address of the actual block} + LSelfPtr := @Self; + LActualBlock := PFullDebugBlockHeader(PByte(LSelfPtr) - SizeOf(TFullDebugBlockHeader)); + + LMsgPtr := @LErrorMessage[0]; + LInitialPtr := LMsgPtr; + LInitialSize := (SizeOf(LErrorMessage) div SizeOf(LErrorMessage[0]))-1; + + + {Display the error header} + LMsgPtr := AppendStringToBuffer(VirtualMethodErrorHeader, @LErrorMessage[0], Length(VirtualMethodErrorHeader), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {Is the debug info surrounding the block valid?} + if CalculateHeaderCheckSum(LActualBlock) = LActualBlock.HeaderCheckSum then + begin + {Get the class this block was used for previously} + LClass := DetectClassInstance(@LActualBlock.PreviouslyUsedByClass); + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then + begin + LMsgPtr := AppendStringToBuffer(FreedObjectClassMsg, LMsgPtr, Length(FreedObjectClassMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Get the virtual method name} + LMsgPtr := AppendStringToBuffer(VirtualMethodName, LMsgPtr, Length(VirtualMethodName), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + if LVMOffset < 0 then + begin + LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)]), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end + else + begin + LMsgPtr := AppendStringToBuffer(VirtualMethodOffset, LMsgPtr, Length(VirtualMethodOffset), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(LVMOffset, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Virtual method address} + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then + begin + LMsgPtr := AppendStringToBuffer(VirtualMethodAddress, LMsgPtr, Length(VirtualMethodAddress), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToHexBuf(PNativeUInt(PByte(LClass) + LVMOffset)^, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Log the allocation group} + if LActualBlock.AllocationGroup > 0 then + begin + LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationGroup, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Log the allocation number} + LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationNumber, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + {The header is still intact - display info about the this/previous allocation} + if LActualBlock.AllocationStackTrace[0] <> 0 then + begin + LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectAllocMsg, LMsgPtr, Length(ThreadIDAtObjectAllocMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToHexBuf(LActualBlock.AllocatedByThread, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := LogStackTrace(@LActualBlock.AllocationStackTrace[0], StackTraceDepth, LMsgPtr); + end; + {Get the call stack for the previous free} + if LActualBlock.FreeStackTrace[0] <> 0 then + begin + LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectFreeMsg, LMsgPtr, Length(ThreadIDAtObjectFreeMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToHexBuf(LActualBlock.FreedByThread, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + LMsgPtr := LogStackTrace(@LActualBlock.FreeStackTrace[0], StackTraceDepth, LMsgPtr); + end; + end + else + begin + {Header has been corrupted} + LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedNoHistoryMsg, LMsgPtr, Length(BlockHeaderCorruptedNoHistoryMsg), LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); + end; + {Add the current stack trace} + LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); +{$ifndef DisableLoggingOfMemoryDumps} + {Add the pointer address} + LMsgPtr := LogMemoryDump(LActualBlock, LMsgPtr, LInitialSize-NativeUint(LMsgPtr-LInitialPtr)); +{$endif} + {Trailing CRLF} + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + {Trailing #0} + LMsgPtr^ := #0; +{$ifdef LogErrorsToFile} + {Log the error} + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); +{$endif} +{$ifdef UseOutputDebugString} + OutputDebugStringA(LErrorMessage); +{$endif} +{$ifndef NoMessageBoxes} + {Show the message} + AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle, Length(BlockErrorMsgTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + ShowMessageBox(LErrorMessage, LErrorMessageTitle); +{$endif} + {Raise an access violation} + RaiseException(EXCEPTION_ACCESS_VIOLATION, 0, 0, nil); +end; + +{$ifdef CatchUseOfFreedInterfaces} +procedure TFreedObject.InterfaceError; +var + LMsgPtr, LInitialPtr: PAnsiChar; +{$ifndef NoMessageBoxes} + LErrorMessageTitle: array[0..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} + LErrorMessage: array[0..MaxLogMessageLength-1] of AnsiChar; + LInitialSize: Cardinal; +begin + FillChar(LErrorMessage, SizeOf(LErrorMessage), 0); + {$ifndef NoMessageBoxes} + FillChar(LErrorMessageTitle, SizeOf(LErrorMessageTitle), 0); + {$endif} + LMsgPtr := @LErrorMessage[0]; + LInitialPtr := LMsgPtr; + LInitialSize := MaxLogMessageLength; + LMsgPtr := AppendStringToBuffer(InterfaceErrorHeader, LMsgPtr, length(InterfaceErrorHeader), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + {Add the current stack trace} + LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + {Trailing CRLF} + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + {Trailing #0} + LMsgPtr^ := #0; +{$ifdef LogErrorsToFile} + {Log the error} + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); +{$endif} +{$ifdef UseOutputDebugString} + OutputDebugStringA(LErrorMessage); +{$endif} +{$ifndef NoMessageBoxes} + {Show the message} + AppendStringToModuleName(BlockErrorMsgTitle, LErrorMessageTitle, Length(BlockErrorMsgTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + 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 (UIntPtr(LPInsertAfter^.LeakAddress) = UIntPtr(APNewEntry^.LeakAddress)) + and ((UIntPtr(LPInsertAfter^.LeakedClass) = UIntPtr(APNewEntry^.LeakedClass)) + {$ifdef CheckCppObjectTypeEnabled} + or (LPInsertAfter^.LeakedCppTypeIdPtr = APNewEntry.LeakedCppTypeIdPtr) + {$endif} + ) + and ((LPInsertAfter^.LeakSize = APNewEntry^.LeakSize) + or ((not AExactSizeMatch) + and (LPInsertAfter^.LeakSize < APNewEntry^.LeakSize) + and ((LPInsertAfter^.NextLeak = nil) + or (LPInsertAfter^.NextLeak^.LeakSize > APNewEntry^.LeakSize)) + )) then + begin + if (LPInsertAfter^.LeakCount + APNewEntry^.LeakCount) >= 0 then + begin + Inc(LPInsertAfter^.LeakCount, APNewEntry^.LeakCount); + {Is the count now 0?} + if LPInsertAfter^.LeakCount = 0 then + begin + {Delete the entry} + if LPInsertAfter^.NextLeak <> nil then + LPInsertAfter^.NextLeak^.PreviousLeak := LPInsertAfter^.PreviousLeak; + if LPInsertAfter^.PreviousLeak <> nil then + LPInsertAfter^.PreviousLeak^.NextLeak := LPInsertAfter^.NextLeak + else + APLeakList^ := LPInsertAfter^.NextLeak; + {Insert it as the first free slot} + LPInsertAfter^.NextLeak := ExpectedMemoryLeaks^.FirstFreeSlot; + ExpectedMemoryLeaks^.FirstFreeSlot := LPInsertAfter; + end; + Result := True; + end; + Exit; + end; + {Next entry} + if LPInsertAfter^.NextLeak <> nil then + LPInsertAfter := LPInsertAfter^.NextLeak + else + Break; + end; + if APNewEntry^.LeakCount > 0 then + begin + {Get a position for the entry} + LPNewEntry := ExpectedMemoryLeaks^.FirstFreeSlot; + if LPNewEntry <> nil then + begin + ExpectedMemoryLeaks^.FirstFreeSlot := LPNewEntry^.NextLeak; + end + else + begin + if ExpectedMemoryLeaks^.EntriesUsed < Length(ExpectedMemoryLeaks^.ExpectedLeaks) then + begin + LPNewEntry := @ExpectedMemoryLeaks^.ExpectedLeaks[ExpectedMemoryLeaks^.EntriesUsed]; + Inc(ExpectedMemoryLeaks^.EntriesUsed); + end + else + begin + {No more space} + Exit; + end; + end; + {Set the entry} + LPNewEntry^ := APNewEntry^; + {Insert it into the list} + LPNewEntry^.PreviousLeak := LPInsertAfter; + if LPInsertAfter <> nil then + begin + LPNewEntry^.NextLeak := LPInsertAfter^.NextLeak; + if LPNewEntry^.NextLeak <> nil then + LPNewEntry^.NextLeak^.PreviousLeak := LPNewEntry; + LPInsertAfter^.NextLeak := LPNewEntry; + end + else + begin + LPNewEntry^.NextLeak := APLeakList^; + if LPNewEntry^.NextLeak <> nil then + LPNewEntry^.NextLeak^.PreviousLeak := LPNewEntry; + APLeakList^ := LPNewEntry; + end; + Result := True; + end; +end; + +{Locks the expected leaks. Returns false if the list could not be allocated.} +function LockExpectedMemoryLeaksList: Boolean; +begin + {Lock the expected leaks list} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + while not AcquireLockByte(ExpectedMemoryLeaksListLocked) do + begin +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThreadIfSupported; + {$endif} +{$else} + Sleep(InitialSleepTime); + if AcquireLockByte(ExpectedMemoryLeaksListLocked) then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; + end; + {Allocate the list if it does not exist} + if ExpectedMemoryLeaks = nil then + ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE); + {Done} + Result := ExpectedMemoryLeaks <> nil; +end; + +{Registers expected memory leaks. Returns true on success. The list of leaked + blocks is limited, so failure is possible if the list is full.} +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; +var + LNewEntry: TExpectedMemoryLeak; +begin + {Fill out the structure} +{$ifndef FullDebugMode} + LNewEntry.LeakAddress := ALeakedPointer; +{$else} + LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); +{$endif} + LNewEntry.LeakedClass := nil; + {$ifdef CheckCppObjectTypeEnabled} + LNewEntry.LeakedCppTypeIdPtr := nil; + {$endif} + LNewEntry.LeakSize := 0; + LNewEntry.LeakCount := 1; + {Add it to the correct list} + Result := LockExpectedMemoryLeaksList + and UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryByAddress, @LNewEntry); +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + ReleaseLockByte(ExpectedMemoryLeaksListLocked); +end; + +function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; +var + LNewEntry: TExpectedMemoryLeak; +begin + {Fill out the structure} + LNewEntry.LeakAddress := nil; + LNewEntry.LeakedClass := ALeakedObjectClass; + {$ifdef CheckCppObjectTypeEnabled} + LNewEntry.LeakedCppTypeIdPtr := nil; + {$endif} + LNewEntry.LeakSize := ALeakedObjectClass.InstanceSize; + LNewEntry.LeakCount := ACount; + {Add it to the correct list} + Result := LockExpectedMemoryLeaksList + and UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryByClass, @LNewEntry); +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + ReleaseLockByte(ExpectedMemoryLeaksListLocked); +end; + +{$ifdef CheckCppObjectTypeEnabled} +function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload; +var + LNewEntry: TExpectedMemoryLeak; +begin + {Fill out the structure} + if Assigned(GetCppVirtObjSizeByTypeIdPtrFunc) then + begin + //Return 0 if not a proper type + LNewEntry.LeakSize := GetCppVirtObjSizeByTypeIdPtrFunc(ALeakedCppVirtObjTypeIdPtr); + if LNewEntry.LeakSize > 0 then + begin + LNewEntry.LeakAddress := nil; + LNewEntry.LeakedClass := nil; + LNewEntry.LeakedCppTypeIdPtr := ALeakedCppVirtObjTypeIdPtr; + LNewEntry.LeakCount := ACount; + {Add it to the correct list} + Result := LockExpectedMemoryLeaksList + and UpdateExpectedLeakList(@ExpectedMemoryLeaks.FirstEntryByClass, @LNewEntry); + {$ifndef AssumeMultiThreaded} + if IsMultiThread then + {$endif} + ReleaseLockByte(@ExpectedMemoryLeaksListLocked); + end + else + begin + Result := False; + end; + end + else + begin + Result := False; + end; +end; +{$endif} + +function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; +var + LNewEntry: TExpectedMemoryLeak; +begin + {Fill out the structure} + LNewEntry.LeakAddress := nil; + LNewEntry.LeakedClass := nil; + {$ifdef CheckCppObjectTypeEnabled} + LNewEntry.LeakedCppTypeIdPtr := nil; + {$endif} + LNewEntry.LeakSize := ALeakedBlockSize; + LNewEntry.LeakCount := ACount; + {Add it to the correct list} + Result := LockExpectedMemoryLeaksList + and UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryBySizeOnly, @LNewEntry); +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + ReleaseLockByte(ExpectedMemoryLeaksListLocked); +end; + +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; +var + LNewEntry: TExpectedMemoryLeak; +begin + {Fill out the structure} +{$ifndef FullDebugMode} + LNewEntry.LeakAddress := ALeakedPointer; +{$else} + LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); +{$endif} + LNewEntry.LeakedClass := nil; + {$ifdef CheckCppObjectTypeEnabled} + LNewEntry.LeakedCppTypeIdPtr := nil; + {$endif} + LNewEntry.LeakSize := 0; + LNewEntry.LeakCount := -1; + {Remove it from the list} + Result := LockExpectedMemoryLeaksList + and UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryByAddress, @LNewEntry); +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + ReleaseLockByte(ExpectedMemoryLeaksListLocked); +end; + +function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; +begin + Result := RegisterExpectedMemoryLeak(ALeakedObjectClass, - ACount); +end; + +{$ifdef CheckCppObjectTypeEnabled} +function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload; +begin + Result := RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr, - ACount); +end; +{$endif} + +function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; +begin + Result := RegisterExpectedMemoryLeak(ALeakedBlockSize, - ACount); +end; + +{Returns a list of all expected memory leaks} +function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks; + + procedure AddEntries(AEntry: PExpectedMemoryLeak); + var + LInd: Integer; + begin + while AEntry <> nil do + begin + LInd := Length(Result); + SetLength(Result, LInd + 1); + {Add the entry} +{$ifndef FullDebugMode} + Result[LInd].LeakAddress := AEntry^.LeakAddress; +{$else} + Result[LInd].LeakAddress := Pointer(PByte(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader)); +{$endif} + Result[LInd].LeakedClass := AEntry^.LeakedClass; +{$ifdef CheckCppObjectTypeEnabled} + Result[LInd].LeakedCppTypeIdPtr := AEntry.LeakedCppTypeIdPtr; +{$endif} + Result[LInd].LeakSize := AEntry^.LeakSize; + Result[LInd].LeakCount := AEntry^.LeakCount; + {Next entry} + AEntry := AEntry^.NextLeak; + end; + end; + +begin + SetLength(Result, 0); + if (ExpectedMemoryLeaks <> nil) and LockExpectedMemoryLeaksList then + begin + {Add all entries} + AddEntries(ExpectedMemoryLeaks^.FirstEntryByAddress); + AddEntries(ExpectedMemoryLeaks^.FirstEntryByClass); + AddEntries(ExpectedMemoryLeaks^.FirstEntryBySizeOnly); + {Unlock the list} + ReleaseLockByte(ExpectedMemoryLeaksListLocked); + end; +end; + +{$else} + {$ifdef BDS2006AndUp} +function NoOpRegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin + {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.} + Result := False; +end; + +function NoOpUnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin + {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.} + Result := False; +end; + {$endif} +{$endif} + +{Detects the probable string data type for a memory block.} +function DetectStringData(APMemoryBlock: Pointer; + AAvailableSpaceInBlock: NativeInt): TStringDataType; +const + {If the string reference count field contains a value greater than this, + then it is assumed that the block is not a string.} + MaxRefCount = 255; + {The lowest ASCII character code considered valid string data. If there are + any characters below this code point then the data is assumed not to be a + string. #9 = Tab.} + MinCharCode = #9; +var + LStringLength, + LElemSize, + LCharInd: Integer; + LPAnsiStr: PAnsiChar; + LPUniStr: PWideChar; +begin + {Check that the reference count is within a reasonable range} + if PStrRec(APMemoryBlock)^.refCnt > MaxRefCount then + begin + Result := stUnknown; + Exit; + end; +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + LElemSize := PStrRec(APMemoryBlock).elemSize; + {Element size must be either 1 (Ansi) or 2 (Unicode)} + if (LElemSize <> 1) and (LElemSize <> 2) then + begin + Result := stUnknown; + Exit; + end; + {$ifend} + {$if RTLVersion < 20} + LElemSize := 1; + {$ifend} +{$else} + LElemSize := 1; +{$endif} + {Get the string length} + LStringLength := PStrRec(APMemoryBlock)^.length; + {Does the string fit?} + if (LStringLength <= 0) + or (LStringLength >= (AAvailableSpaceInBlock - SizeOf(StrRec)) div LElemSize) then + begin + Result := stUnknown; + Exit; + end; + {Check for no characters outside the expected range. If there are, + then it is probably not a string.} + if LElemSize = 1 then + begin + {Check that all characters are in the range considered valid.} + LPAnsiStr := PAnsiChar(PByte(APMemoryBlock) + SizeOf(StrRec)); + for LCharInd := 1 to LStringLength do + begin + if LPAnsiStr^ < MinCharCode then + begin + Result := stUnknown; + Exit; + end; + Inc(LPAnsiStr); + end; + {Must have a trailing #0} + if LPAnsiStr^ = #0 then + Result := stAnsiString + else + Result := stUnknown; + end + else + begin + {Check that all characters are in the range considered valid.} + LPUniStr := PWideChar(PByte(APMemoryBlock) + SizeOf(StrRec)); + for LCharInd := 1 to LStringLength do + begin + if LPUniStr^ < MinCharCode then + begin + Result := stUnknown; + Exit; + end; + Inc(LPUniStr); + end; + {Must have a trailing #0} + if LPUniStr^ = #0 then + Result := stUnicodeString + else + Result := stUnknown; + end; +end; + +{Walks all allocated blocks, calling ACallBack for each. Passes the user block size and AUserData to the callback. + Important note: All block types will be locked during the callback, so the memory manager cannot be used inside it.} +procedure WalkAllocatedBlocks(ACallBack: TWalkAllocatedBlocksCallback; AUserData: Pointer); +const + DebugHeaderSize = {$ifdef FullDebugMode}SizeOf(TFullDebugBlockHeader){$else}0{$endif}; + TotalDebugOverhead = {$ifdef FullDebugMode}FullDebugBlockOverhead{$else}0{$endif}; +var + LPMediumBlock: Pointer; + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LMediumBlockHeader: NativeUInt; + LPLargeBlock: PLargeBlockHeader; + LBlockSize: NativeInt; + LPSmallBlockPool: PSmallBlockPoolHeader; + LCurPtr, + LEndPtr: Pointer; + LInd: Integer; +{$ifdef LogLockContention} + LDidSleep: Boolean; +{$endif} +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked: Boolean; + LLargeBlocksLocked: Boolean; +{$endif} +begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := False; + LLargeBlocksLocked := False; +{$endif} + {Lock all small block types} + LockAllSmallBlockTypes; + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + end; + try + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Is the block in use?} + if (LMediumBlockHeader and IsFreeBlockFlag) = 0 then + begin + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Step through all the blocks in the small block pool} + LPSmallBlockPool := LPMediumBlock; + {Get the useable size inside a block} + LBlockSize := LPSmallBlockPool^.BlockType^.BlockSize - BlockHeaderSize - TotalDebugOverhead; + {Get the first and last pointer for the pool} + GetFirstAndLastSmallBlockInPool(LPSmallBlockPool, LCurPtr, LEndPtr); + {Step through all blocks} + while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do + begin + {Is this block in use?} + if (PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0 then + begin + ACallBack(PByte(LCurPtr) + DebugHeaderSize, LBlockSize, AUserData); + end; + {Next block} + Inc(PByte(LCurPtr), LPSmallBlockPool^.BlockType^.BlockSize); + end; + end + else + begin + LBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize - TotalDebugOverhead; + ACallBack(PByte(LPMediumBlock) + DebugHeaderSize, LBlockSize, AUserData); + end; + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader^.NextMediumBlockPoolHeader; + end; + finally + {Unlock medium blocks} +{$ifndef AssumeMultiThreaded} + if LMediumBlocksLocked then +{$endif} + begin + // LMediumBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockMediumBlocks; + end; + {Unlock all the small block types} + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + ReleaseLockByte(SmallBlockTypes[LInd].SmallBlockTypeLocked); + end; + end; +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := True; +{$endif} + {Step through all the large blocks} + {$ifdef LogLockContention}LDidSleep :={$endif} + LockLargeBlocks; + end; + try + {Get all leaked large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + LBlockSize := (LPLargeBlock^.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize - TotalDebugOverhead; + ACallBack(PByte(LPLargeBlock) + LargeBlockHeaderSize + DebugHeaderSize, LBlockSize, AUserData); + {Get the next large block} + LPLargeBlock := LPLargeBlock^.NextLargeBlockHeader; + end; + finally +{$ifndef AssumeMultiThreaded} + if LLargeBlocksLocked then +{$endif} + begin + // LLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockLargeBlocks; + end; + end; +end; + +{-----------LogMemoryManagerStateToFile implementation------------} +const + MaxMemoryLogNodes = 100000; + QuickSortMinimumItemsInPartition = 4; + +type + {While scanning the memory pool the list of classes is built up in a binary search tree.} + PMemoryLogNode = ^TMemoryLogNode; + TMemoryLogNode = record + {The left and right child nodes} + LeftAndRightNodePointers: array[Boolean] of PMemoryLogNode; + {The class this node belongs to} + ClassPtr: TClass; + {The number of instances of the class} + InstanceCount: NativeInt; + {The total memory usage for this class} + TotalMemoryUsage: NativeInt; + end; + TMemoryLogNodes = array[0..MaxMemoryLogNodes - 1] of TMemoryLogNode; + PMemoryLogNodes = ^TMemoryLogNodes; + + TMemoryLogInfo = record + {The number of nodes in "Nodes" that are used.} + NodeCount: Integer; + {The root node of the binary search tree. The content of this node is not actually used, it just simplifies the + binary search code.} + RootNode: TMemoryLogNode; + Nodes: TMemoryLogNodes; + end; + PMemoryLogInfo = ^TMemoryLogInfo; + +{LogMemoryManagerStateToFile callback subroutine} +procedure LogMemoryManagerStateCallBack(APBlock: Pointer; ABlockSize: NativeInt; AUserData: Pointer); +var + LClass, + LClassHashBits: NativeUInt; + LPLogInfo: PMemoryLogInfo; + LPParentNode, + LPClassNode: PMemoryLogNode; + LChildNodeDirection: Boolean; +begin + LPLogInfo := AUserData; + {Detecting an object is very expensive (due to the VirtualQuery call), so we do some basic checks and try to find + the "class" in the tree first.} + LClass := PNativeUInt(APBlock)^; + {Do some basic pointer checks: The "class" must be dword aligned and beyond 64K} + if (LClass > 65535) + and ((LClass and 3) = 0) then + begin + LPParentNode := @LPLogInfo^.RootNode; + LClassHashBits := LClass; + repeat + LChildNodeDirection := Boolean(LClassHashBits and 1); + {Split off the next bit of the class pointer and traverse in the appropriate direction.} + LPClassNode := LPParentNode^.LeftAndRightNodePointers[LChildNodeDirection]; + {Is this child node the node the class we're looking for?} + if (LPClassNode = nil) or (NativeUInt(LPClassNode^.ClassPtr) = LClass) then + Break; + {The node was not found: Keep on traversing the tree.} + LClassHashBits := LClassHashBits shr 1; + LPParentNode := LPClassNode; + until False; + end + else + LPClassNode := nil; + {Was the "class" found?} + if LPClassNode = nil then + begin + {The "class" is not yet in the tree: Determine if it is actually a class.} + LClass := NativeUInt(DetectClassInstance(APBlock)); + {If it is not a class, try to detect the string type.} + if LClass = 0 then + LClass := Ord(DetectStringData(APBlock, ABlockSize)); + {Is this class already in the tree?} + LPParentNode := @LPLogInfo^.RootNode; + LClassHashBits := LClass; + repeat + LChildNodeDirection := Boolean(LClassHashBits and 1); + {Split off the next bit of the class pointer and traverse in the appropriate direction.} + LPClassNode := LPParentNode^.LeftAndRightNodePointers[LChildNodeDirection]; + {Is this child node the node the class we're looking for?} + if LPClassNode = nil then + begin + {The end of the tree was reached: Add a new child node.} + LPClassNode := @LPLogInfo^.Nodes[LPLogInfo^.NodeCount]; + Inc(LPLogInfo^.NodeCount); + LPParentNode^.LeftAndRightNodePointers[LChildNodeDirection] := LPClassNode; + LPClassNode^.ClassPtr := TClass(LClass); + Break; + end + else + begin + if NativeUInt(LPClassNode^.ClassPtr) = LClass then + Break; + end; + {The node was not found: Keep on traversing the tree.} + LClassHashBits := LClassHashBits shr 1; + LPParentNode := LPClassNode; + until False; + end; + {Update the statistics for the class} + Inc(LPClassNode^.InstanceCount); + Inc(LPClassNode^.TotalMemoryUsage, ABlockSize); +end; + +{This function is only needed to copy with an error given when using +the "typed @ operator" compiler option. We are having just one typecast +in this function to avoid using typecasts throught the entire program.} +function GetNodeListFromNode(ANode: PMemoryLogNode): PMemoryLogNodes; + {$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif} +begin + {We have only one typecast here, in other places we have strict type checking} + Result := PMemoryLogNodes(ANode); +end; + +{LogMemoryManagerStateToFile subroutine: A median-of-3 quicksort routine for sorting a TMemoryLogNodes array.} +procedure QuickSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer); +var + LPLeftItem: PMemoryLogNodes; + LRightIndex: Integer; + M, I, J: Integer; + LPivot, + LTempItem: TMemoryLogNode; + PMemLogNode: PMemoryLogNode; {This variable is just neede to simplify the accomodation + to "typed @ operator" - stores an intermediary value} +begin + LPLeftItem := APLeftItem; + LRightIndex := ARightIndex; + while True do + begin + {Order the left, middle and right items in ascending order} + M := LRightIndex shr 1; + {Is the middle item larger than the left item?} + if LPLeftItem^[0].TotalMemoryUsage > LPLeftItem^[M].TotalMemoryUsage then + begin + {Swap items 0 and M} + LTempItem := LPLeftItem^[0]; + LPLeftItem^[0] := LPLeftItem^[M]; + LPLeftItem^[M] := LTempItem; + end; + {Is the middle item larger than the right?} + if LPLeftItem^[M].TotalMemoryUsage > LPLeftItem^[LRightIndex].TotalMemoryUsage then + begin + {The right-hand item is not larger - swap it with the middle} + LTempItem := LPLeftItem^[LRightIndex]; + LPLeftItem^[LRightIndex] := LPLeftItem^[M]; + LPLeftItem^[M] := LTempItem; + {Is the left larger than the new middle?} + if LPLeftItem^[0].TotalMemoryUsage > LPLeftItem^[M].TotalMemoryUsage then + begin + {Swap items 0 and M} + LTempItem := LPLeftItem^[0]; + LPLeftItem^[0] := LPLeftItem^[M]; + LPLeftItem^[M] := LTempItem; + end; + end; + {Move the pivot item out of the way by swapping M with R - 1} + LPivot := LPLeftItem^[M]; + LPLeftItem^[M] := LPLeftItem^[LRightIndex - 1]; + LPLeftItem^[LRightIndex - 1] := LPivot; + {Set up the loop counters} + I := 0; + J := LRightIndex - 1; + while True do + begin + {Find the first item from the left that is not smaller than the pivot} + repeat + Inc(I); + until LPLeftItem^[I].TotalMemoryUsage >= LPivot.TotalMemoryUsage; + {Find the first item from the right that is not larger than the pivot} + repeat + Dec(J); + until LPLeftItem^[J].TotalMemoryUsage <= LPivot.TotalMemoryUsage; + {Stop the loop when the two indexes cross} + if J < I then + Break; + {Swap item I and J} + LTempItem := LPLeftItem^[I]; + LPLeftItem^[I] := LPLeftItem^[J]; + LPLeftItem^[J] := LTempItem; + end; + {Put the pivot item back in the correct position by swapping I with R - 1} + LPLeftItem^[LRightIndex - 1] := LPLeftItem^[I]; + LPLeftItem^[I] := LPivot; + {Sort the left-hand partition} + if J >= (QuickSortMinimumItemsInPartition - 1) then + QuickSortLogNodes(LPLeftItem, J); + {Sort the right-hand partition} + PMemLogNode := @(LPLeftItem[I + 1]); + LPLeftItem := GetNodeListFromNode(PMemLogNode); + LRightIndex := LRightIndex - I - 1; + if LRightIndex < (QuickSortMinimumItemsInPartition - 1) then + Break; + end; +end; + +{LogMemoryManagerStateToFile subroutine: An InsertionSort routine for sorting a TMemoryLogNodes array.} +procedure InsertionSortLogNodes(APLeftItem: PMemoryLogNodes; ARightIndex: Integer); +var + I, J: Integer; + LCurNode: TMemoryLogNode; +begin + for I := 1 to ARightIndex do + begin + LCurNode := APLeftItem^[I]; + {Scan backwards to find the best insertion spot} + J := I; + while (J > 0) and (APLeftItem^[J - 1].TotalMemoryUsage > LCurNode.TotalMemoryUsage) do + begin + APLeftItem^[J] := APLeftItem^[J - 1]; + Dec(J); + end; + APLeftItem^[J] := LCurNode; + end; +end; + +{Writes a log file containing a summary of the memory mananger state and a summary of allocated blocks grouped by + class. The file will be saved in UTF-8 encoding (in supported Delphi versions). Returns True on success. } +function LogMemoryManagerStateToFile(const AFileName: string; const AAdditionalDetails: string): Boolean; +const + MsgBufferSize = 65536; + MaxLineLength = 512; + {Write the UTF-8 BOM in Delphi versions that support UTF-8 conversion.} + LogStateHeaderMsg = {$ifdef BCB6OrDelphi7AndUp}#$EF#$BB#$BF + {$endif} + 'FastMM State Capture:'#13#10'---------------------'#13#10#13#10; + LogStateAllocatedMsg = 'K Allocated'#13#10; + LogStateOverheadMsg = 'K Overhead'#13#10; + LogStateEfficiencyMsg = '% Efficiency'#13#10#13#10'Usage Detail:'#13#10; + LogStateAdditionalInfoMsg = #13#10'Additional Information:'#13#10'-----------------------'#13#10; + AverageSizeLeadText = ' ('; + AverageSizeTrailingText = ' bytes avg.)'#13#10; +var + LUMsg, + LUBuf: NativeUInt; + LPLogInfo: PMemoryLogInfo; + LInd: Integer; + LPNode: PMemoryLogNode; + LMsgBuffer: array[0..MsgBufferSize - 1] of AnsiChar; + LPInitialMsgPtr, + LPMsg: PAnsiChar; + LBufferSpaceUsed, + LBytesWritten: Cardinal; + LFileHandle: THandle; {use NativeUint if THandle is not available} + LMemoryManagerUsageSummary: TMemoryManagerUsageSummary; + LUTF8Str: AnsiString; + LMemLogNode: PMemoryLogNode; {Just to store an interim result. Needed for + "typed @ operator", to simplify things and remove + typecasts that pose potential dannger.} + LInitialSize: Cardinal; + LCallback: TWalkAllocatedBlocksCallback; +begin + {Get the current memory manager usage summary.} + GetMemoryManagerUsageSummary(LMemoryManagerUsageSummary); + {Allocate the memory required to capture detailed allocation information.} + LPLogInfo := VirtualAlloc(nil, SizeOf(TMemoryLogInfo), MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE); + if LPLogInfo <> nil then + begin + try + {Log all allocated blocks by class.} + LCallback := {$ifdef FPC}@{$endif}LogMemoryManagerStateCallBack; + WalkAllocatedBlocks(LCallback, LPLogInfo); + {Sort the classes by total memory usage: Do the initial QuickSort pass over the list to sort the list in groups + of QuickSortMinimumItemsInPartition size.} + if LPLogInfo^.NodeCount >= QuickSortMinimumItemsInPartition then + begin + LMemLogNode := @(LPLogInfo^.Nodes[0]); + QuickSortLogNodes(GetNodeListFromNode(LMemLogNode), LPLogInfo^.NodeCount - 1); + end; + {Do the final InsertionSort pass.} + LMemLogNode := @(LPLogInfo^.Nodes[0]); + InsertionSortLogNodes(GetNodeListFromNode(LMemLogNode), LPLogInfo^.NodeCount - 1); + {Create the output file} + {$ifdef POSIX} + lFileHandle := FileCreate(AFilename); + {$else} + LFileHandle := CreateFile(PChar(AFilename), GENERIC_READ or GENERIC_WRITE, 0, + nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + {$endif} + if LFileHandle <> INVALID_HANDLE_VALUE then + begin + try + {Log the usage summary} + LPMsg := @(LMsgBuffer[0]); + LPInitialMsgPtr := LPMsg; + LInitialSize := (SizeOf(LMsgBuffer) div SizeOf(LMsgBuffer[0]))-1; + LPMsg := AppendStringToBuffer(LogStateHeaderMsg, LPMsg, Length(LogStateHeaderMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.AllocatedBytes shr 10, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(LogStateAllocatedMsg, LPMsg, Length(LogStateAllocatedMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := NativeUIntToStrBuf(LMemoryManagerUsageSummary.OverheadBytes shr 10, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(LogStateOverheadMsg, LPMsg, Length(LogStateOverheadMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := NativeUIntToStrBuf(Round(LMemoryManagerUsageSummary.EfficiencyPercentage), LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(LogStateEfficiencyMsg, LPMsg, Length(LogStateEfficiencyMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + {Log the allocation detail} + for LInd := LPLogInfo^.NodeCount - 1 downto 0 do + begin + LPNode := @(LPLogInfo^.Nodes[LInd]); + {Add the allocated size} + LPMsg^ := ' '; + Inc(LPMsg); + LPMsg := NativeUIntToStrBuf(LPNode^.TotalMemoryUsage, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(BytesMessage, LPMsg, Length(BytesMessage), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + {Add the class type} + case NativeUInt(LPNode^.ClassPtr) of + {Unknown} + 0: + begin + LPMsg := AppendStringToBuffer(UnknownClassNameMsg, LPMsg, Length(UnknownClassNameMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + end; + {AnsiString} + 1: + begin + LPMsg := AppendStringToBuffer(AnsiStringBlockMessage, LPMsg, Length(AnsiStringBlockMessage), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + end; + {UnicodeString} + 2: + begin + LPMsg := AppendStringToBuffer(UnicodeStringBlockMessage, LPMsg, Length(UnicodeStringBlockMessage), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + end; + {Classes} + else + begin + LPMsg := AppendClassNameToBuffer(LPNode^.ClassPtr, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + end; + end; + {Add the count} + LPMsg^ := ' '; + Inc(LPMsg); + LPMsg^ := 'x'; + Inc(LPMsg); + LPMsg^ := ' '; + Inc(LPMsg); + LPMsg := NativeUIntToStrBuf(LPNode^.InstanceCount, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(AverageSizeLeadText, LPMsg, Length(AverageSizeLeadText), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := NativeUIntToStrBuf(LPNode^.TotalMemoryUsage div LPNode^.InstanceCount, LPMsg, LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + LPMsg := AppendStringToBuffer(AverageSizeTrailingText, LPMsg, Length(AverageSizeTrailingText), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + {Flush the buffer?} + LUMsg := NativeUInt(LPMsg); + LUBuf := NativeUInt(@LMsgBuffer); + if LUMsg > LUBuf then + begin + LBufferSpaceUsed := LUMsg - LUBuf; + if LBufferSpaceUsed > (MsgBufferSize - MaxLineLength) then + begin + LBytesWritten := 0; + WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil); + LPMsg := @(LMsgBuffer[0]); + end; + end; + end; + if AAdditionalDetails <> '' then + begin + LPMsg := AppendStringToBuffer(LogStateAdditionalInfoMsg, LPMsg, Length(LogStateAdditionalInfoMsg), LInitialSize-NativeUInt(LPMsg-LPInitialMsgPtr)); + end; + {Flush any remaining bytes} + LUMsg := NativeUInt(LPMsg); + LUBuf := NativeUInt(@LMsgBuffer); + if LUMsg > LUBuf then + begin + LBufferSpaceUsed := LUMsg - LUBuf; + WriteFile(LFileHandle, LMsgBuffer, LBufferSpaceUsed, LBytesWritten, nil); + end; + {Write the additional info} + if AAdditionalDetails <> '' then + begin + {$ifdef BCB6OrDelphi7AndUp} + LUTF8Str := UTF8Encode(AAdditionalDetails); + {$else} + LUTF8Str := AAdditionalDetails; + {$endif} + if Length(LUTF8Str) > 0 then + begin + WriteFile(LFileHandle, PAnsiChar(LUTF8Str)^, Length(LUTF8Str), LBytesWritten, nil); + end; + end; + {Success} + Result := True; + finally + {Close the file} + {$ifdef POSIX} + {$ifndef fpc} + __close(LFileHandle) + {$else} + fpclose(LFileHandle) + {$endif} + {$else} + CloseHandle(LFileHandle); + {$endif} + end; + end + else + Result := False; + finally + VirtualFree(LPLogInfo, 0, MEM_RELEASE); + end; + end + else + Result := False; +end; + +{-----------CheckBlocksOnShutdown implementation------------} + +{Checks blocks for modification after free and also for memory leaks} +procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); +{$ifdef EnableMemoryLeakReporting} +type + {Leaked class type} + TLeakedClass = record + ClassPointer: TClass; + {$ifdef CheckCppObjectTypeEnabled} + CppTypeIdPtr: Pointer; + {$endif} + NumLeaks: Cardinal; + end; + TLeakedClasses = array[0..255] of TLeakedClass; + PLeakedClasses = ^TLeakedClasses; + {Leak statistics for a small block type} + TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses; + {A leaked medium or large block} + TMediumAndLargeBlockLeaks = array[0..4095] of NativeUInt; +{$endif} +var +{$ifdef EnableMemoryLeakReporting} + {The leaked classes for small blocks} + LSmallBlockLeaks: TSmallBlockLeaks; + LLeakType: TMemoryLeakType; + {$ifdef CheckCppObjectTypeEnabled} + LLeakedCppTypeIdPtr: Pointer; + LCppTypeName: PAnsiChar; + {$endif} + LMediumAndLargeBlockLeaks: TMediumAndLargeBlockLeaks; + LNumMediumAndLargeLeaks: Integer; + LPLargeBlock: PLargeBlockHeader; + LLeakMessage: array[0..MaxLogMessageLength-1] of AnsiChar; + {$ifndef NoMessageBoxes} + LMessageTitleBuffer: array[0..MaxDisplayMessageLength-1] of AnsiChar; + {$endif} + LPInitialPtr, LMsgPtr: PAnsiChar; + LInitialSize: Cardinal; + LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean; + LBlockTypeInd, LClassInd, LBlockInd: Cardinal; + LMediumBlockSize, LPreviousBlockSize, LLargeBlockSize, LThisBlockSize: NativeUInt; +{$endif} + LPMediumBlock: Pointer; + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LMediumBlockHeader: NativeUInt; + +{$ifdef EnableMemoryLeakReporting} + {Tries to account for a memory leak. Returns true if the leak is expected and + removes the leak from the list} + function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: NativeUInt): TMemoryLeakType; + var + LLeak: TExpectedMemoryLeak; + begin + {Default to not found} + Result := mltUnexpectedLeak; + if ExpectedMemoryLeaks <> nil then + begin + {Check by pointer address} + LLeak.LeakAddress := AAddress; + LLeak.LeakedClass := nil; + {$ifdef CheckCppObjectTypeEnabled} + LLeak.LeakedCppTypeIdPtr := nil; + {$endif} + LLeak.LeakSize := 0; + LLeak.LeakCount := -1; + if UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryByAddress, @LLeak, False) then + begin + Result := mltExpectedLeakRegisteredByPointer; + Exit; + end; + {Check by class} + LLeak.LeakAddress := nil; + {$ifdef FullDebugMode} + LLeak.LeakedClass := TClass(PNativeUInt(PByte(AAddress)+ SizeOf(TFullDebugBlockHeader))^); + {$else} + LLeak.LeakedClass := TClass(PNativeUInt(AAddress)^); + {$endif} + {$ifdef CheckCppObjectTypeEnabled} + if Assigned(GetCppVirtObjTypeIdPtrFunc) then + begin + {$ifdef FullDebugMode} + LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(Pointer(PByte(AAddress) + + SizeOf(TFullDebugBlockHeader)), ASpaceInsideBlock); + {$else} + LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(AAddress, ASpaceInsideBlock); + {$endif} + end; + LLeakedCppTypeIdPtr := LLeak.LeakedCppTypeIdPtr; + {$endif} + LLeak.LeakSize := ASpaceInsideBlock; + if UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryByClass, @LLeak, False) then + begin + Result := mltExpectedLeakRegisteredByClass; + Exit; + end; + {Check by size: the block must be large enough to hold the leak} + LLeak.LeakedClass := nil; + if UpdateExpectedLeakList(@ExpectedMemoryLeaks^.FirstEntryBySizeOnly, @LLeak, False) then + Result := mltExpectedLeakRegisteredBySize; + end; + end; + + {Checks the small block pool for leaks.} + procedure CheckSmallBlockPoolForLeaks(APSmallBlockPool: PSmallBlockPoolHeader); + var + LLeakedClass: TClass; + {$ifdef CheckCppObjectTypeEnabled} + LLeakedCppObjectTypeId: Pointer; + {$endif} + LSmallBlockLeakType: TMemoryLeakType; + LClassIndex: Integer; + LCurPtr, LEndPtr, LDataPtr: Pointer; + LBlockTypeIndex: Cardinal; + LPLeakedClasses: PLeakedClasses; + LSmallBlockSize: Cardinal; + begin + {Get the useable size inside a block} + LSmallBlockSize := APSmallBlockPool^.BlockType^.BlockSize - BlockHeaderSize; + {$ifdef FullDebugMode} + Dec(LSmallBlockSize, FullDebugBlockOverhead); + {$endif} + {Get the block type index} + LBlockTypeIndex := (UIntPtr(APSmallBlockPool^.BlockType) - UIntPtr(@SmallBlockTypes[0])) +{$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shr SmallBlockTypeRecSizePowerOf2 +{$else} + div SmallBlockTypeRecSize +{$endif} + ; + LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex]; + {Get the first and last pointer for the pool} + GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr); + {Step through all blocks} + while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do + begin + {Is this block in use? If so, is the debug info intact?} + if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then + begin + {$ifdef FullDebugMode} + if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then + {$endif} + begin + {$ifdef CheckCppObjectTypeEnabled} + LLeakedCppTypeIdPtr := nil; + {$endif} + {Get the leak type} + LSmallBlockLeakType := GetMemoryLeakType(LCurPtr, LSmallBlockSize); + {$ifdef LogMemoryLeakDetailToFile} + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + LogMemoryLeakOrAllocatedBlock(LCurPtr, True); + {$endif} + {Only expected leaks?} + LExpectedLeaksOnly := LExpectedLeaksOnly and (LSmallBlockLeakType <> mltUnexpectedLeak); + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LSmallBlockLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + begin + {Get a pointer to the user data} + {$ifndef FullDebugMode} + LDataPtr := LCurPtr; + {$else} + LDataPtr := Pointer(PByte(LCurPtr) + SizeOf(TFullDebugBlockHeader)); + {$endif} + {Default to an unknown block} + LClassIndex := 0; + {Get the class contained by the block} + LLeakedClass := DetectClassInstance(LDataPtr); + {Not a Delphi class? -> is it perhaps a string or C++ object type?} + if LLeakedClass = nil then + begin + {$ifdef CheckCppObjectTypeEnabled} + LLeakedCppObjectTypeId := LLeakedCppTypeIdPtr; + if (LLeakedCppObjectTypeId = nil) and (ExpectedMemoryLeaks = nil) then + begin + if Assigned(GetCppVirtObjTypeIdPtrFunc) then + begin + LLeakedCppObjectTypeId := GetCppVirtObjTypeIdPtrFunc(LDataPtr, LSmallBlockSize); + end; + end; + if Assigned(LLeakedCppObjectTypeId) then + begin + LClassIndex := 3; + while LClassIndex <= High(TLeakedClasses) do + begin + if (Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) = LLeakedCppObjectTypeId) + or ((LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil) + and (LPLeakedClasses[LClassIndex].ClassPointer = nil)) then + begin + Break; + end; + Inc(LClassIndex); + end; + if LClassIndex <= High(TLeakedClasses) then + Pointer(LPLeakedClasses[LClassIndex].CppTypeIdPtr) := LLeakedCppObjectTypeId + else + LClassIndex := 0; + end + else + begin + {$endif} + {Not a known class: Is it perhaps string data?} + case DetectStringData(LDataPtr, APSmallBlockPool^.BlockType^.BlockSize - (BlockHeaderSize {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif})) of + stAnsiString: LClassIndex := 1; + stUnicodeString: LClassIndex := 2; + end; + {$ifdef CheckCppObjectTypeEnabled} + end; + {$endif} + end + else + begin + LClassIndex := 3; + while LClassIndex <= High(TLeakedClasses) do + begin + if (LPLeakedClasses^[LClassIndex].ClassPointer = LLeakedClass) + or ((LPLeakedClasses^[LClassIndex].ClassPointer = nil) + {$ifdef CheckCppObjectTypeEnabled} + and (LPLeakedClasses[LClassIndex].CppTypeIdPtr = nil) + {$endif} + ) then + begin + Break; + end; + Inc(LClassIndex); + end; + if LClassIndex <= High(TLeakedClasses) then + LPLeakedClasses^[LClassIndex].ClassPointer := LLeakedClass + else + LClassIndex := 0; + end; + {Add to the number of leaks for the class} + Inc(LPLeakedClasses^[LClassIndex].NumLeaks); + end; + end; + end + else + begin + {$ifdef CheckUseOfFreedBlocksOnShutdown} + {Check that the block has not been modified since being freed} + CheckFreeBlockUnmodified(LCurPtr, APSmallBlockPool.BlockType.BlockSize, boBlockCheck); + {$endif} + end; + {Next block} + Inc(PByte(LCurPtr), APSmallBlockPool^.BlockType^.BlockSize); + end; + end; +{$endif} + +begin +{$ifdef EnableMemoryLeakReporting} + {Clear the leak arrays} + FillChar(LSmallBlockLeaks, SizeOf(LSmallBlockLeaks), 0); + FillChar(LMediumAndLargeBlockLeaks, SizeOf(LMediumAndLargeBlockLeaks), 0); + {Step through all the medium block pools} + LNumMediumAndLargeLeaks := 0; + {No unexpected leaks so far} + LExpectedLeaksOnly := True; +{$endif} + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Is the block in use?} + if (LMediumBlockHeader and IsFreeBlockFlag) = 0 then + begin +{$ifdef EnableMemoryLeakReporting} + if ACheckForLeakedBlocks then + begin + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get all the leaks for the small block pool} + CheckSmallBlockPoolForLeaks(LPMediumBlock); + end + else + begin + if (LNumMediumAndLargeLeaks < Length(LMediumAndLargeBlockLeaks)) + {$ifdef FullDebugMode} + and CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) + {$endif} + then + begin + LMediumBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize; + {$ifdef FullDebugMode} + Dec(LMediumBlockSize, FullDebugBlockOverhead); + {$endif} + {Get the leak type} + LLeakType := GetMemoryLeakType(LPMediumBlock, LMediumBlockSize); + {Is it an expected leak?} + LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak); + {$ifdef LogMemoryLeakDetailToFile} + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + LogMemoryLeakOrAllocatedBlock(LPMediumBlock, True); + {$endif} + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + begin + {Add the leak to the list} + LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LMediumBlockSize; + Inc(LNumMediumAndLargeLeaks); + end; + end; + end; + end; +{$endif} + end + else + begin +{$ifdef CheckUseOfFreedBlocksOnShutdown} + {Check that the block has not been modified since being freed} + CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck); +{$endif} + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader^.NextMediumBlockPoolHeader; + end; +{$ifdef EnableMemoryLeakReporting} + if ACheckForLeakedBlocks then + begin + {Get all leaked large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks)) + {$ifdef FullDebugMode} + and CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) + {$endif} + then + begin + LLargeBlockSize := (LPLargeBlock^.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) - BlockHeaderSize - LargeBlockHeaderSize; + {$ifdef FullDebugMode} + Dec(LLargeBlockSize, FullDebugBlockOverhead); + {$endif} + {Get the leak type} + LLeakType := GetMemoryLeakType(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize); + {Is it an expected leak?} + LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak); + {$ifdef LogMemoryLeakDetailToFile} + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), True); + {$endif} + {$ifdef HideExpectedLeaksRegisteredByPointer} + if LLeakType <> mltExpectedLeakRegisteredByPointer then + {$endif} + begin + {Add the leak} + LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LLargeBlockSize; + Inc(LNumMediumAndLargeLeaks); + end; + end; + {Get the next large block} + LPLargeBlock := LPLargeBlock^.NextLargeBlockHeader; + end; + {Display the leak message if required} + if not LExpectedLeaksOnly then + begin + {Small leak header has not been added} + LSmallLeakHeaderAdded := False; + LPreviousBlockSize := 0; + {Set up the leak message header so long} + + LMsgPtr := @LLeakMessage[0]; + LPInitialPtr := LMsgPtr; + LInitialSize := (SizeOf(LLeakMessage) div SizeOf(LLeakMessage[0]))-1; + + + LMsgPtr := AppendStringToBuffer(LeakMessageHeader, LMsgPtr, length(LeakMessageHeader), LInitialSize); + {Step through all the small block types} + for LBlockTypeInd := 0 to NumSmallBlockTypes - 1 do + begin + LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize; + {$ifdef FullDebugMode} + if LThisBlockSize > FullDebugBlockOverhead then + begin + Dec(LThisBlockSize, FullDebugBlockOverhead); + end else + begin + LThisBlockSize := 0; + end; + {$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) - MaxFileNameLengthDouble] 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), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + LSmallLeakHeaderAdded := True; + end; + {Need to add the size header?} + if not LBlockSizeHeaderAdded then + begin + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LPreviousBlockSize + 1, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := '-'; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LThisBlockSize, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + 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), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + end; + {AnsiString} + 1: + begin + LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + end; + {UnicodeString} + 2: + begin + LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + end; + {Classes} + else + begin + {$ifdef CheckCppObjectTypeEnabled} + if LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr <> nil then + begin + if Assigned(GetCppVirtObjTypeNameByTypeIdPtrFunc) then + begin + LCppTypeName := GetCppVirtObjTypeNameByTypeIdPtrFunc(LSmallBlockLeaks[LBlockTypeInd][LClassInd].CppTypeIdPtr); + LMsgPtr := AppendStringToBuffer(LCppTypeName, LMsgPtr, StrLen(LCppTypeName)); + end + else + LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr); + end + else + begin + {$endif} + LMsgPtr := AppendClassNameToBuffer(LSmallBlockLeaks[LBlockTypeInd][LClassInd].ClassPointer, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + {$ifdef CheckCppObjectTypeEnabled} + end; + {$endif} + end; + end; + {Add the count} + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := 'x'; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + 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), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + {List all the blocks} + for LBlockInd := 0 to LNumMediumAndLargeLeaks - 1 do + begin + if LBlockInd <> 0 then + begin + LMsgPtr^ := ','; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + end; + LMsgPtr := NativeUIntToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + {Is there still space in the message buffer? Reserve space for the + message footer.} + if LMsgPtr > @LLeakMessage[High(LLeakMessage) - MaxFileNameLengthDouble] then + Break; + end; + end; + {$ifdef LogErrorsToFile} + {Set the message footer} + LMsgPtr := AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + {Append the message to the memory errors file} + AppendEventLog(@LLeakMessage[0], UIntPtr(LMsgPtr) - UIntPtr(@LLeakMessage[1])); + {$else} + {Set the message footer} + AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter), LInitialSize-NativeUInt(LMsgPtr-LPInitialPtr)); + {$endif} + {$ifdef UseOutputDebugString} + OutputDebugStringA(LLeakMessage); + {$endif} + {$ifndef NoMessageBoxes} + {Show the message} + AppendStringToModuleName(LeakMessageTitle, LMessageTitleBuffer, Length(LeakMessageTitle), (SizeOf(LMessageTitleBuffer) div SizeOf(LMessageTitleBuffer[0]))-1); + ShowMessageBox(LLeakMessage, LMessageTitleBuffer); + {$endif} + end; + end; +{$endif} +end; + +{Returns statistics about the current state of the memory manager} +procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); +const + BlockHeaderSizeWithAnyOverhead = BlockHeaderSize{$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif}; +var + LIndBlockSize, + LUsableBlockSize: Cardinal; + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumBlock: Pointer; + LInd: Integer; + LBlockTypeIndex, + LMediumBlockSize: Cardinal; + LMediumBlockHeader, + LLargeBlockSize: NativeUInt; + LPLargeBlock: PLargeBlockHeader; +{$ifdef LogLockContention} + LDidSleep: Boolean; +{$endif} +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked: Boolean; + LLargeBlocksLocked: Boolean; +{$endif} +begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := False; + LLargeBlocksLocked := False; +{$endif} + {Clear the structure} + FillChar(AMemoryManagerState, SizeOf(AMemoryManagerState), 0); + {Set the small block size stats} + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + LIndBlockSize := SmallBlockTypes[LInd].BlockSize; + AMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize := LIndBlockSize; + if LIndBlockSize > BlockHeaderSizeWithAnyOverhead then + begin + LUsableBlockSize := LIndBlockSize - BlockHeaderSizeWithAnyOverhead + end else + begin + LUsableBlockSize := 0; + end; + AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := LUsableBlockSize; + end; +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + {Lock all small block types} + LockAllSmallBlockTypes; + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + end; + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the medium block used space} + Inc(AMemoryManagerState.ReservedMediumBlockAddressSpace, MediumBlockPoolSize); + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Is the block in use?} + if (LMediumBlockHeader and IsFreeBlockFlag) = 0 then + begin + {Get the block size} + LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask; + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get the block type index} + LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock)^.BlockType) - UIntPtr(@SmallBlockTypes[0])) + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shr SmallBlockTypeRecSizePowerOf2 + {$else} + div SmallBlockTypeRecSize + {$endif} + ; + {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} +{$ifndef AssumeMultiThreaded} + if LMediumBlocksLocked then +{$endif} + begin + // LMediumBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockMediumBlocks; + end; + {Unlock all the small block types} + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + ReleaseLockByte(SmallBlockTypes[LInd].SmallBlockTypeLocked); + end; +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := True; +{$endif} + {Step through all the large blocks} + {$ifdef LogLockContention}LDidSleep:={$endif} + LockLargeBlocks; + end; + 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; +{$ifndef AssumeMultiThreaded} + if LLargeBlocksLocked then +{$endif} + begin + // LLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockLargeBlocks; + end; +end; + +{Returns a summary of the information returned by GetMemoryManagerState} +function GetMemoryManagerUsageSummary: TMemoryManagerUsageSummary; +var + LMMS: TMemoryManagerState; + LAllocatedBytes, + LReservedBytes: NativeUInt; + LSBTIndex: Integer; +begin + {Get the memory manager state} + GetMemoryManagerState(LMMS); + {Add up the totals} + LAllocatedBytes := LMMS.TotalAllocatedMediumBlockSize + LMMS.TotalAllocatedLargeBlockSize; + LReservedBytes := LMMS.ReservedMediumBlockAddressSpace + LMMS.ReservedLargeBlockAddressSpace; + for LSBTIndex := 0 to NumSmallBlockTypes - 1 do + begin + Inc(LAllocatedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].UseableBlockSize + * LMMS.SmallBlockTypeStates[LSBTIndex].AllocatedBlockCount); + Inc(LReservedBytes, LMMS.SmallBlockTypeStates[LSBTIndex].ReservedAddressSpace); + end; + {Set the structure values} + Result.AllocatedBytes := LAllocatedBytes; + Result.OverheadBytes := LReservedBytes - LAllocatedBytes; + if LReservedBytes > 0 then + Result.EfficiencyPercentage := LAllocatedBytes / LReservedBytes * 100 + else + Result.EfficiencyPercentage := 100; +end; + +procedure GetMemoryManagerUsageSummary(var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary); +begin + AMemoryManagerUsageSummary := GetMemoryManagerUsageSummary; +end; + +{$ifndef POSIX} +{Gets the state of every 64K block in the 4GB address space. Under 64-bit this + returns only the state for the low 4GB.} +procedure GetMemoryMap(var AMemoryMap: TMemoryMap); +var + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPLargeBlock: PLargeBlockHeader; + LIndNUI, + LChunkIndex, + LNextChunk, + LLargeBlockSize: NativeUInt; + LMBI: TMemoryBasicInformation; + LCharToFill: AnsiChar; +{$ifdef LogLockContention} + LDidSleep: Boolean; +{$endif} +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked: Boolean; + LLargeBlocksLocked: Boolean; +{$endif} +begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := False; + LLargeBlocksLocked := False; +{$endif} + {Clear the map} + FillChar(AMemoryMap, SizeOf(AMemoryMap), Ord(csUnallocated)); + {Step through all the medium block pools} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + end; + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the medium block used space} + LChunkIndex := NativeUInt(LPMediumBlockPoolHeader) shr 16; + for LIndNUI := 0 to (MediumBlockPoolSize - 1) shr 16 do + begin + if (LChunkIndex + LIndNUI) > High(AMemoryMap) then + Break; + AMemoryMap[LChunkIndex + LIndNUI] := csAllocated; + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader^.NextMediumBlockPoolHeader; + end; +{$ifndef AssumeMultiThreaded} + if LMediumBlocksLocked then +{$endif} + begin + // LMediumBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockMediumBlocks; + end; + {Step through all the large blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep:={$endif} + LockLargeBlocks; + end; + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + LChunkIndex := UIntPtr(LPLargeBlock) shr 16; + LLargeBlockSize := LPLargeBlock^.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; + for LIndNUI := 0 to (LLargeBlockSize - 1) shr 16 do + begin + if (LChunkIndex + LIndNUI) > High(AMemoryMap) then + Break; + AMemoryMap[LChunkIndex + LIndNUI] := csAllocated; + end; + {Get the next large block} + LPLargeBlock := LPLargeBlock^.NextLargeBlockHeader; + end; +{$ifndef AssumeMultiThreaded} + if LLargeBlocksLocked then +{$endif} + begin + // LLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockLargeBlocks; + end; + {Fill in the rest of the map} + LIndNUI := 0; + while LIndNUI <= 65535 do + begin + {If the chunk is not allocated by this MM, what is its status?} + if AMemoryMap[LIndNUI] = csUnallocated then + begin + {Query the address space starting at the chunk boundary} + if VirtualQuery(Pointer(LIndNUI * 65536), LMBI, SizeOf(LMBI)) = 0 then + begin + {VirtualQuery may fail for addresses >2GB if a large address space is + not enabled.} + LCharToFill := AnsiChar(csSysReserved); + FillChar(AMemoryMap[LIndNUI], 65536 - LIndNUI, LCharToFill); + Break; + end; + {Get the chunk number after the region} + LNextChunk := ((LMBI.RegionSize - 1) shr 16) + LIndNUI + 1; + {Validate} + if LNextChunk > 65536 then + LNextChunk := 65536; + {Set the status of all the chunks in the region} + if LMBI.State = MEM_COMMIT then + begin + LCharToFill := AnsiChar(csSysReserved); + FillChar(AMemoryMap[LIndNUI], LNextChunk - LIndNUI, LCharToFill); + end + else + begin + if LMBI.State = MEM_RESERVE then + begin + LCharToFill := AnsiChar(csSysReserved); + FillChar(AMemoryMap[LIndNUI], LNextChunk - LIndNUI, LCharToFill); + end; + end; + {Point to the start of the next chunk} + LIndNUI := LNextChunk; + end + else + begin + {Next chunk} + Inc(LIndNUI); + end; + end; +end; +{$endif} + +{This function is a helper function neede when using the "typed @ operator" +to have lowest possible number of typecats - just in this function. It is defined ad +"inline", so, when optimization compiler directive is turned on, this function will +be implemented in such a way that no actual code will be needed and no call/return.} +function SmallBlockTypePtrToPoolHeaderPtr(ASmallBlockTypePtr: PSmallBlockType): PSmallBlockPoolHeader; + {$ifdef FASTMM4_ALLOW_INLINES}inline;{$endif} +begin + {This function just does one typecast to avoid typecasts elsewhere} + Result := PSmallBlockPoolHeader(ASmallBlockTypePtr); +end; + +{Returns summarised information about the state of the memory manager. (For + backward compatibility.)} +function FastGetHeapStatus: THeapStatus; +var + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumBlock: Pointer; + LBlockTypeIndex, + LMediumBlockSize: Cardinal; + LSmallBlockUsage, + LSmallBlockOverhead, + LMediumBlockHeader, + LLargeBlockSize: NativeUInt; + LInd: Integer; + LPLargeBlock: PLargeBlockHeader; +{$ifdef LogLockContention} + LDidSleep: Boolean; +{$endif} +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked: Boolean; + LLargeBlocksLocked: Boolean; +{$endif} +begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := False; + LLargeBlocksLocked := False; +{$endif} + {Clear the structure} + FillChar(Result, SizeOf(Result), 0); + {Lock all small block types} + LockAllSmallBlockTypes; + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LMediumBlocksLocked := True; +{$endif} + {$ifdef LogLockContention}LDidSleep := {$endif}LockMediumBlocks; + end; + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the total and committed address space} + Inc(Result.TotalAddrSpace, ((MediumBlockPoolSize + $ffff) and $ffff0000)); + Inc(Result.TotalCommitted, ((MediumBlockPoolSize + $ffff) and $ffff0000)); + {Add the medium block pool overhead} + Inc(Result.Overhead, (((MediumBlockPoolSize + $ffff) and $ffff0000) + - MediumBlockPoolSize + MediumBlockPoolHeaderSize)); + {Get the first medium block in the pool} + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + {Get the block header} + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Get the block size} + LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask; + {Is the block in use?} + if (LMediumBlockHeader and IsFreeBlockFlag) = 0 then + begin + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get the block type index} + LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock)^.BlockType) - UIntPtr(@SmallBlockTypes[0])) + {$ifdef SmallBlockTypeRecSizeIsPowerOf2} + shr SmallBlockTypeRecSizePowerOf2 + {$else} + div SmallBlockTypeRecSize + {$endif} + ; + {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} +{$ifndef AssumeMultiThreaded} + if LMediumBlocksLocked then +{$endif} + begin + // LMediumBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockMediumBlocks; + end; + {Unlock all the small block types} + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + ReleaseLockByte(SmallBlockTypes[LInd].SmallBlockTypeLocked); + end; +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin +{$ifndef AssumeMultiThreaded} + LLargeBlocksLocked := True; +{$endif} + {Step through all the large blocks} + {$ifdef LogLockContention}LDidSleep:={$endif} + LockLargeBlocks; + end; + 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; +{$ifndef AssumeMultiThreaded} + if LLargeBlocksLocked then +{$endif} + begin + // LLargeBlocksLocked := False; {this assignment produces a compiler "hint", but might have been useful for further development} + UnlockLargeBlocks; + end; + {Set the total number of free bytes} + Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused; +end; + +{$ifdef fpc} +function FastGetFPCHeapStatus: TFPCHeapStatus; //support get TFPCHeapStatus +var + HS: THeapStatus; +begin + HS := FastGetHeapStatus; + Result.MaxHeapSize := HS.TotalAddrSpace; + Result.MaxHeapUsed := HS.TotalAllocated; + Result.CurrHeapSize := HS.TotalAddrSpace; + Result.CurrHeapUsed := HS.TotalAllocated; + Result.CurrHeapFree := HS.TotalFree; +end; +{$endif} + +{Frees all allocated memory. Does not support segmented large blocks (yet).} +procedure FreeAllMemory; +var + LPMediumBlockPoolHeader, + LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumFreeBlock: PMediumFreeBlock; + LPLargeBlock, + LPNextLargeBlock: PLargeBlockHeader; + LPSmallBlockPoolHeader: PSmallBlockPoolHeader; {This is needed for simplicity, to + mitigate typecasts when used "typed @".} + LPSmallBlockType: PSmallBlockType; + LInd: Integer; +begin + {Free all block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Get the next medium block pool so long} + LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader^.NextMediumBlockPoolHeader; +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0); +{$else} + {$ifdef ClearSmallAndMediumBlocksInFreeMem} + FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0); + {$endif} +{$endif} + {Free this pool} + VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE); + {Next pool} + LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + end; + {Clear all small block types} + for LInd := Low(SmallBlockTypes) to High(SmallBlockTypes) do + begin + LPSmallBlockType := @(SmallBlockTypes[Lind]); + LPSmallBlockPoolHeader := SmallBlockTypePtrToPoolHeaderPtr(LPSmallBlockType); + SmallBlockTypes[Lind].PreviousPartiallyFreePool := LPSmallBlockPoolHeader; + SmallBlockTypes[Lind].NextPartiallyFreePool := LPSmallBlockPoolHeader; + 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 := Low(MediumBlockBins) to High(MediumBlockBins) do + begin + LPMediumFreeBlock := @(MediumBlockBins[LInd]); + LPMediumFreeBlock^.PreviousFreeBlock := LPMediumFreeBlock; + LPMediumFreeBlock^.NextFreeBlock := LPMediumFreeBlock; + end; + MediumBlockBinGroupBitmap := 0; + FillChar(MediumBlockBinBitmaps, SizeOf(MediumBlockBinBitmaps), 0); + MediumSequentialFeedBytesLeft := 0; + {Free all large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + {Get the next large block} + LPNextLargeBlock := LPLargeBlock^.NextLargeBlockHeader; +{$ifdef ClearLargeBlocksBeforeReturningToOS} + FillChar(LPLargeBlock^, + LPLargeBlock^.BlockSizeAndFlags and DropMediumAndLargeFlagsMask, 0); +{$endif} + {Free this large block} + VirtualFree(LPLargeBlock, 0, MEM_RELEASE); + {Next large block} + LPLargeBlock := LPNextLargeBlock; + end; + {There are no large blocks allocated} + LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList; +end; + +{Returns the current installation state of the memory manager.} +function FastMM_GetInstallationState: TFastMM_MemoryManagerInstallationState; +begin + if IsMemoryManagerSet then + begin + if FastMMIsInstalled then + begin + if IsMemoryManagerOwner then + Result := mmisInstalled + else + Result := mmisUsingSharedMemoryManager; + end + else + Result := mmisOtherThirdPartyMemoryManagerInstalled + end + else + Result := mmisDefaultMemoryManagerInUse; +end; + +{$ifdef LogLockContention} +procedure ReportLockContention; +var + count: Integer; + data: TStaticCollector.TCollectedData; + i: Integer; + LErrorMessage: array[0..MaxLogMessageLength-1] of AnsiChar; + LMessageTitleBuffer: array[0..MaxDisplayMessageLength-1] of AnsiChar; + LMsgPtr, LInitialPtr: PAnsiChar; + LInitialSize: Cardinal; + mergedCount: Integer; + mergedData: TStaticCollector.TCollectedData; +begin + LargeBlockCollector.GetData(mergedData, mergedCount); + MediumBlockCollector.GetData(data, count); + LargeBlockCollector.Merge(mergedData, mergedCount, data, count); + for i := 0 to High(SmallBlockTypes) do + begin + SmallBlockTypes[i].BlockCollector.GetData(data, count); + LargeBlockCollector.Merge(mergedData, mergedCount, data, count); + end; + + if mergedCount > 0 then + begin + FillChar(LErrorMessage, SizeOf(LErrorMessage), 0); + FillChar(LMessageTitleBuffer, SizeOf(LMessageTitleBuffer), 0); + LMsgPtr := @LErrorMessage[0]; + LInitialPtr := LMsgPtr; + LInitialSize := MaxLogMessageLength; + LMsgPtr := AppendStringToBuffer(LockingReportHeader, LMsgPtr, Length(LockingReportHeader), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + for i := 1 to 3 do + begin + if i > mergedCount then + break; //for i + if i > 1 then + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(mergedData[i].Count, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + if LInitialSize-NativeUInt(LMsgPtr-LInitialPtr) < 5 then Break; + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := 'x'; + Inc(LMsgPtr); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := LogStackTrace(PNativeUInt(@(mergedData[i].Data.Pointers[1])), mergedData[i].Data.Count, LMsgPtr); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + end; +{$ifndef NoMessageBoxes} + AppendStringToModuleName(LockingReportTitle, LMessageTitleBuffer, Length(LockingReportTitle), (SizeOf(LMessageTitleBuffer) div SizeOf(LMessageTitleBuffer[0]))-1); + ShowMessageBox(LErrorMessage, LMessageTitleBuffer); +{$endif} + for i := 4 to 10 do + begin + if i > mergedCount then + break; //for i + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := NativeUIntToStrBuf(mergedData[i].Count, LMsgPtr, LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + if LInitialSize-NativeUInt(LMsgPtr-LInitialPtr) < 5 then Break; + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := 'x'; + Inc(LMsgPtr); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + LMsgPtr := LogStackTrace(PNativeUInt(@(mergedData[i].Data.Pointers[1])), mergedData[i].Data.Count, LMsgPtr); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + end; + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF), LInitialSize-NativeUInt(LMsgPtr-LInitialPtr)); + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); + end; +end; +{$endif} + +{$ifdef UseReleaseStack} +{$ifdef DebugReleaseStack} +procedure GetBlockSizeForStack(const AStack: TLFStack; var ABlockSize: NativeUInt; var ACount: integer); +var + LBlockHeader: NativeUInt; + LMemBlock: pointer; + LTmpStack: TLFStack; +begin + ABlockSize := 0; + ACount := 0; + LTmpStack.Initialize(ReleaseStackSize, SizeOf(pointer)); + while AStack.Pop(LMemBlock) do + begin + {Move each block to a temporary stack as we'll have to put them back later} + LTmpStack.Push(LMemBlock); + + Inc(ACount); + + LBlockHeader := PNativeUInt(PByte(LMemBlock) - BlockHeaderSize)^; + + {Block should always be in use!} + if (LBlockHeader and IsFreeBlockFlag) <> 0 then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end + {Is this a medium block?} + else if (LBlockHeader and IsMediumBlockFlag) <> 0 then + Inc(ABlockSize, LBlockHeader and DropMediumAndLargeFlagsMask) + {Is this a large block?} + else if (LBlockHeader and IsLargeBlockFlag) <> 0 then + Inc(ABlockSize, PLargeBlockHeader(Pointer(PByte(LMemBlock) - LargeBlockHeaderSize)).UserAllocatedSize) + {It must be a small block} + else + Inc(ABlockSize, PSmallBlockPoolHeader(LBlockHeader).BlockType.BlockSize); + end; + + {Cleanup, move memory blocks back to the release stack} + while LTmpStack.Pop(LMemBlock) do + AStack.Push(LMemBlock); + LTmpStack.Finalize; +end; + +procedure LogReleaseStackUsage; + + procedure NewLine; + begin + LMsgPtr^ := #13; Inc(LMsgPtr); + LMsgPtr^ := #10; Inc(LMsgPtr); + end; + + procedure AppendMemorySize(ASize: NativeUInt); + begin + if ASize < 10*1024 then + begin + LMsgPtr := NativeUIntToStrBuf(Round(ASize/1024), LMsgPtr); + LMsgPtr^ := ' '; Inc(LMsgPtr); + LMsgPtr^ := 'K'; Inc(LMsgPtr); + LMsgPtr^ := 'B'; Inc(LMsgPtr); + end + else if ASize < 10*1024*1024 then + begin + LMsgPtr := NativeUIntToStrBuf(Round(ASize/1024), LMsgPtr); + LMsgPtr^ := ' '; Inc(LMsgPtr); + LMsgPtr^ := 'K'; Inc(LMsgPtr); + LMsgPtr^ := 'B'; Inc(LMsgPtr); + end + else if (ASize div 1024) < 10*1024*1024 then + begin + LMsgPtr := NativeUIntToStrBuf(Round(ASize/1024/1024), LMsgPtr); + LMsgPtr^ := ' '; Inc(LMsgPtr); + LMsgPtr^ := 'M'; Inc(LMsgPtr); + LMsgPtr^ := 'B'; Inc(LMsgPtr); + end + else + begin + LMsgPtr := NativeUIntToStrBuf(Round(ASize/1024/1024/1024), LMsgPtr); + LMsgPtr^ := ' '; Inc(LMsgPtr); + LMsgPtr^ := 'G'; Inc(LMsgPtr); + LMsgPtr^ := 'B'; Inc(LMsgPtr); + end; + end; + + procedure AppendSlotInfo(ABlockSize: Integer); + var + LCount: Integer; + LSlot: Integer; + LTotal: NativeUInt; + begin + if ABlockSize > 0 then + begin + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageSmallBlocksMsg1, LMsgPtr, Length(ReleaseStackUsageSmallBlocksMsg1)); + LMsgPtr := NativeUIntToStrBuf(ABlockSize, LMsgPtr); + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageSmallBlocksMsg2, LMsgPtr, Length(ReleaseStackUsageSmallBlocksMsg2)); + end + else if ABlockSize = -1 then + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageMediumBlocksMsg, LMsgPtr, Length(ReleaseStackUsageMediumBlocksMsg)) + else + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageLargeBlocksMsg, LMsgPtr, Length(ReleaseStackUsageLargeBlocksMsg)); + + LTotal := 0; + LCount := 0; + for LSlot := 0 to NumStacksPerBlock-1 do + begin + Inc(LTotal, LSlotSize[LSlot]); + Inc(LCount, LSlotCount[LSlot]); + end; + + AppendMemorySize(LTotal); + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageBuffers1Msg, LMsgPtr, Length(ReleaseStackUsageBuffers1Msg)); + LMsgPtr := NativeUIntToStrBuf(LCount, LMsgPtr); + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageBuffers2Msg, LMsgPtr, Length(ReleaseStackUsageBuffers2Msg)); + for LSlot := 0 to NumStacksPerBlock-1 do + begin + AppendMemorySize(LSlotSize[LSlot]); + LMsgPtr^ := '/'; + Inc(LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSlotCount[LSlot], LMsgPtr); + if LSlot < (NumStacksPerBlock-1) then + begin + LMsgPtr^ := ' '; + Inc(LMsgPtr); + end; + end; + LMsgPtr^ := ']'; + Inc(LMsgPtr); + + NewLine; + end; + +var + LCount: integer; + LInd: Integer; + LMessage: array[0..MaxLogMessageLength-1] of AnsiChar; + LMsgPtr: PAnsiChar; + LSize: NativeUInt; + LSlot: Integer; + LSlotCount: array[0..NumStacksPerBlock-1] of integer; + LSlotSize: array[0..NumStacksPerBlock-1] of NativeUInt; + LTotalLarge: NativeUInt; + LTotalMedium: NativeUInt; + LTotalSmall: NativeUInt; + LMediumBlocksLocked: Boolean; + LLargeBlocksLocked: Boolean; +begin + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageHeader, @LMessage[0], Length(ReleaseStackUsageHeader)); + NewLine; + NewLine; + +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + LSmallBlocksLocked := True; + LockAllSmallBlockTypes; + LMediumBlocksLocked := True; + LockMediumBlocks; + LLargeBlocksLocked := True; + LockLargeBlocks; + end; + + LTotalSmall := 0; + for LInd := 0 to High(SmallBlockTypes) do begin + for LSlot := 0 to NumStacksPerBlock-1 do begin + GetBlockSizeForStack(SmallBlockTypes[LInd].ReleaseStack[LSlot], LSize, LCount); + LSlotSize[LSlot] := LSize; + LSlotCount[LSlot] := LCount; + Inc(LTotalSmall, LSize); + end; + if LSmallBlocksLocked then + begin + ReleaseLockByte(@SmallBlockTypes[LInd].SmallBlockTypeLocked); + end; + AppendSlotInfo(SmallBlockTypes[LInd].BlockSize); + end; + + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageTotalSmallBlocksMsg, LMsgPtr, Length(ReleaseStackUsageTotalSmallBlocksMsg)); + AppendMemorySize(LTotalSmall); + NewLine; + + LTotalMedium := 0; + for LSlot := 0 to NumStacksPerBlock-1 do begin + GetBlockSizeForStack(MediumReleaseStack[LSlot], LSize, LCount); + LSlotSize[LSlot] := LSize; + LSlotCount[LSlot] := LCount; + Inc(LTotalMedium, LSize); + end; + if LMediumBlocksLocked then + begin + LMediumBlocksLocked := False; + UnlockMediumBlocks; + end; + AppendSlotInfo(-1); + + LTotalLarge := 0; + for LSlot := 0 to NumStacksPerBlock-1 do begin + GetBlockSizeForStack(LargeReleaseStack[LSlot], LSize, LCount); + LSlotSize[LSlot] := LSize; + LSlotCount[LSlot] := LCount; + Inc(LTotalLarge, LSize); + end; + if LLargeBlocksLocked then + begin + LLargeBlocksLocked := False; + UnlockLargeBlocks; + end; + AppendSlotInfo(-2); + + LMsgPtr := AppendStringToBuffer(ReleaseStackUsageTotalMemoryMsg, LMsgPtr, Length(ReleaseStackUsageTotalMemoryMsg)); + AppendMemorySize(LTotalSmall + LTotalMedium + LTotalLarge); + NewLine; + + {Trailing #0} + LMsgPtr^ := #0; + + AppendEventLog(@LMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LMessage[0])); +end; +{$endif} +{$endif} + +{----------------------------Memory Manager Setup-----------------------------} + +{$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} +const + // constants from the Windows SDK v10.0.15063 + XSTATE_LEGACY_FLOATING_POINT = (0); + XSTATE_LEGACY_SSE = (1); + XSTATE_GSSE = (2); + XSTATE_AVX = (XSTATE_GSSE); + XSTATE_MPX_BNDREGS = (3); + XSTATE_MPX_BNDCSR = (4); + XSTATE_AVX512_KMASK = (5); + XSTATE_AVX512_ZMM_H = (6); + XSTATE_AVX512_ZMM = (7); + XSTATE_IPT = (8); + XSTATE_LWP = (62); + MAXIMUM_XSTATE_FEATURES = (64); + +const + cXstateAvx1Mask = (1 shl XSTATE_AVX); + {$ifdef EnableAVX512} + cXstateAvx512Mask = (1 shl XSTATE_AVX512_KMASK) or (1 shl XSTATE_AVX512_ZMM_H) or (1 shl XSTATE_AVX512_ZMM); + {$endif} + +{$endif Use_GetEnabledXStateFeatures_WindowsAPICall} + +{Use the NativeUint argument type to make Delphi clear the trash and not pass +it in bits 63-32 under 64-bit, although the xgetbv instruction only accepts +32-bits from the ECX/RCX register even under 64-bit mode} + +{$ifdef 64bit} + {$ifndef FPC} + { The following compilers do not understand the XGETBV instruction: + - The 32-bit Delphi Tokyo 10.2 assembler; + - FreePascal + } + {$ifdef ASMVersion} + {$define XGetBvAsmSupported} + {$endif} + {$endif} +{$endif} + +{$ifndef PurePascal} +function GetCpuXCR(Arg: NativeUint): Int64; assembler; +asm + {$ifdef 64bit} + +{$ifdef unix} + +{Under Unix 64-bit, the first six integer or pointer arguments are passed +in registers RDI, RSI, RDX, RCX (R10 in the Linux kernel interface), R8, and R9. +The return value is stored in RAX and RDX. +So Unix uses the same register for return value as Microsoft; don't correct +output registers, but correct the input one} + mov ecx, edi // this will also clear the highest bits in ecx (63-32). +{$else} +{$ifdef AllowAsmNoframe} + .noframe +{$endif} +{$endif} + xor eax, eax + xor edx, edx +{ EDX:EAX <- XCR[ECX]; } + +{$ifdef XGetBvAsmSupported} + xgetbv +{$else} + db $0F, $01, $D0 +{$endif} + +{The output of xgetbv is a 64-bit value returned in two 32-bit registers: +eax/edx, even in 64-bit mode, so we should pack eax/edx intto rax} + + shl rdx, 32 + or rax, rdx + xor rdx, rdx + + {$else} + mov ecx, eax + xor eax, eax + xor edx, edx + {$ifdef XGetBvAsmSupported} + xgetbv + {$else} + db $0F, $01, $D0 + {$endif} + {$endif} +end; +{$endif} + +{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..MaxDisplayMessageLength-1] of AnsiChar; +{$endif} +var + HeapTotalAllocated: NativeUInt; +begin + {Default to error} + Result := False; +{$ifdef FullDebugMode} + {$ifdef LoadDebugDLLDynamically} + {$ifdef DoNotInstallIfDLLMissing} + {Should FastMM be installed only if the FastMM_FullDebugMode.dll file is + available?} + if FullDebugModeDLL = 0 then + Exit; + {$endif} + {$endif} +{$endif} + {Is FastMM already installed?} + if FastMMIsInstalled then + begin +{$ifdef UseOutputDebugString} + OutputDebugStringA(AlreadyInstalledMsg); +{$endif} +{$ifndef NoMessageBoxes} + AppendStringToModuleName(AlreadyInstalledTitle, LErrorMessageTitle, Length(AlreadyInstalledTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + ShowMessageBox(AlreadyInstalledMsg, LErrorMessageTitle); +{$endif} + Exit; + end; + {Has another MM been set, or has the Embarcadero MM been used? If so, this + file is not the first unit in the uses clause of the project's .dpr file.} + + if IsMemoryManagerSet then + begin + {When using runtime packages, another library may already have installed + FastMM: Silently ignore the installation request.} +{$ifndef UseRuntimePackages} + {Another memory manager has been set.} + {$ifdef UseOutputDebugString} + OutputDebugStringA(OtherMMInstalledMsg); + {$endif} + {$ifndef NoMessageBoxes} + AppendStringToModuleName(OtherMMInstalledTitle, LErrorMessageTitle, Length(OtherMMInstalledTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + ShowMessageBox(OtherMMInstalledMsg, LErrorMessageTitle); + {$endif} +{$endif} + Exit; + end; + +{$ifndef POSIX} + HeapTotalAllocated := GetHeapStatus.TotalAllocated; +{ In FreePascal, we cannot rely on HeapTotalAllocated to check whether FastMM4 +is the first unit and no memory have been allocated before, by another memory +manager, because the initialization section of the "system.pp" unit of +FreePascal calls the setup_arguments function to allocate memory for the +command line buffers and store these pointers in the "argc" global variable +(checked in versions 3.0.4 and 3.2.0), but version 3.3.1 allocates even more +memory in the initialization of "system.pp". +See https://bugs.freepascal.org/view.php?id=38391 for more details. +Please double-check that the FastMM4 unit is the first unit in the units ("uses") +list of your .lpr file (or any other main file where you define project +units). } +{$ifndef IgnoreMemoryAllocatedBefore} + if HeapTotalAllocated <> 0 then + begin + {Memory has been already been allocated with the RTL MM} +{$ifdef UseOutputDebugString} + OutputDebugStringA(MemoryAllocatedMsg); +{$endif} + {$ifndef NoMessageBoxes} + AppendStringToModuleName(MemoryAllocatedTitle, LErrorMessageTitle, Length(MemoryAllocatedTitle), (SizeOf(LErrorMessageTitle) div SizeOf(LErrorMessageTitle[0]))-1); + {$ifdef FPC} + ShowMessageBox('In FreePascal, we cannot rely on HeapTotalAllocated to check '+ + 'whether FastMM4 is the first unit and no memory has been allocated before, '+ + 'by another memory manager, because the initialization section of the "system.pp" '+ + 'unit of FreePascal calls the setup_arguments function to allocate memory for the command line buffers and store these pointers in the "argc" global variable (checked in versions 3.0.4 and 3.2.0). However, the version 3.3.1 allocates even more memory in the initialization of "system.pp". See https://bugs.freepascal.org/view.php?id=38391 for more details. Please double-check that the FastMM4 unit is the first unit in the units ("uses") list of your .lpr file (or any other main file where you define project units). You can recompile FastMM4-AVX with the IgnoreMemoryAllocatedBefore conditional define, but, in this case, there will be no check whether the FastMM4 is the first unit in the units section, and if it is not the first, you will get errors. Please consider supporting the https://bugs.freepascal.org/view.php?id=38391 and/or improving FreePascal to fix the bug registered under that URL.', LErrorMessageTitle); {$else} + ShowMessageBox(MemoryAllocatedMsg, LErrorMessageTitle); + {$endif} + {$endif} + Exit; + end; +{$endif} +{$endif} + {All OK} + Result := True; +end; + +procedure InitializeInvalidMemoryManager; +begin +{$ifdef DetectMMOperationsAfterUninstall} + with InvalidMemoryManager do + begin + GetMem := {$ifdef FPC}@{$endif}InvalidGetMem; + FreeMem := {$ifdef FPC}@{$endif}InvalidFreeMem; + ReallocMem := {$ifdef FPC}@{$endif}InvalidReallocMem; + {$ifdef BDS2006AndUp} + AllocMem := {$ifdef FPC}@{$endif}InvalidAllocMem; + RegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}InvalidRegisterAndUnRegisterMemoryLeak; + UnRegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}InvalidRegisterAndUnRegisterMemoryLeak; + {$endif} + end; +{$endif} +end; + +procedure InitializeBlockTypeSizes; +var + i: Cardinal; +begin + for i := 0 to NumSmallBlockTypes-1 do + begin + SmallBlockTypes[i].BlockSize := SmallBlockTypeSizes[i]; + end; +end; + +{Initializes the lookup tables for the memory manager} +procedure InitializeMemoryManager; +{$ifdef FullDebugMode} +const + {The size of the Inc(VMTIndex) code in TFreedObject.GetVirtualMethodIndex} + VMTIndexIncCodeSize = 6; +{$endif} + +{$ifdef EnableAVX} + +const + {XCR0[2:1] = '11b' (XMM state and YMM state are enabled by OS).} + CXcrXmmAndYmmMask = (4-1) shl 1; + +{$ifdef EnableAVX512} +const + {XCR0[7:5] = '111b' (OPMASK state, upper 256-bit of ZMM0-ZMM15 and ZMM16-ZMM31 state are enabled by OS).} + CXcrZmmMask = (8-1) shl 5; +{$endif EnableAVX512} + +{$endif EnableAVX} + +{$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} +type + TGetEnabledXStateFeatures = function: Int64; stdcall; +{$endif} + +var + LPSmallBlockPoolHeader: PSmallBlockPoolHeader; + LPSmallBlockType: PSmallBlockType; +{$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + FGetEnabledXStateFeatures: TGetEnabledXStateFeatures; + EnabledXStateFeatures: Int64; +{$endif} + +{$ifdef USE_CPUID} +{$ifdef EnableAVX} + CpuXCR0: Int64; +{$endif} + MaxInputValueBasic: Cardinal; + LReg0, LReg1, LReg7_0: TCpuIdRegisters; +{$endif} + + LInd, + LSizeInd, + LMinimumPoolSize, + LOptimalPoolSize, + LGroupNumber, + LBlocksPerPool, LPreviousBlockSize: Cardinal; + LPMediumFreeBlock: PMediumFreeBlock; +{$ifdef FullDebugMode} + {$ifdef LoadDebugDLLDynamically} + {$ifdef RestrictDebugDLLLoadPath} + LModuleHandle: HModule; + LFullFileName: array[0..MaxFileNameLengthDouble-1] of Char; + {$endif} + {$endif} +{$endif} +{$ifdef UseReleaseStack} + LSlot: Integer; +{$endif} + LByte: Byte; +begin + +{$ifndef DisablePauseAndSwitchToThread} +{$ifndef POSIX} + {$ifdef FPC} + Pointer(FSwitchToThread) + {$else} + FSwitchToThread + {$endif} + := GetProcAddress(GetModuleHandle(Kernel32), 'SwitchToThread'); +{$endif} +{$endif} + +{$ifdef FullDebugMode} + {$ifdef LoadDebugDLLDynamically} + {Attempt to load the FullDebugMode DLL dynamically.} + +{$ifdef RestrictDebugDLLLoadPath} + FullDebugModeDLL := 0; + LModuleHandle := 0; +{$ifndef borlndmmdll} + if IsLibrary then + LModuleHandle := HInstance; +{$endif} + + LSizeInd := GetModuleFileName(LModuleHandle, LFullFileName, Sizeof(LFullFileName) div SizeOf(Char)); + while LSizeInd > 0 do + begin + Dec(LSizeInd); + if LFullFileName[LSizeInd] = '\' then + Break; + end; + if (LSizeInd > 0) and (LSizeInd + Cardinal(Length(FullDebugModeLibraryName)) + 1 < Sizeof(LFullFileName) div SizeOf(Char)) then + begin + LInd := 1; + repeat + LFullFileName[LSizeInd + LInd] := FullDebugModeLibraryName[LInd]; + Inc(LInd); + until LInd > Cardinal(Length(FullDebugModeLibraryName)); + LFullFileName[LSizeInd + LInd] := #0; + FullDebugModeDLL := LoadLibrary(LFullFileName); + end; +{$else} + FullDebugModeDLL := LoadLibrary(FullDebugModeLibraryName); +{$endif} + if FullDebugModeDLL <> 0 then + begin + GetStackTrace := GetProcAddress(FullDebugModeDLL, + {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif}); + LogStackTrace := GetProcAddress(FullDebugModeDLL, 'LogStackTrace'); + end; + {$endif} +{$endif} + + +{$ifdef USE_CPUID} + if CPUID_Supported then + begin + +{ +QUOTE + +Two types of information are returned: basic and extended function information. If a value entered for CPUID.EAX +is higher than the maximum input value for basic or extended function for that processor then the data for the +highest basic information leaf is returned. + +ENDQOTE} + + +//Basic CPUID Information + + with LReg0 do begin RegEAX := 0; RegEBX := 0; RegECX := 0; RegEDX := 0; end; + with LReg1 do begin RegEAX := 0; RegEBX := 0; RegECX := 0; RegEDX := 0; end; + with LReg7_0 do begin RegEAX := 0; RegEBX := 0; RegECX := 0; RegEDX := 0; end; + + GetCPUID(0, 0, LReg0); + MaxInputValueBasic := LReg0.RegEax; + if MaxInputValueBasic > 0 then + begin + if MaxInputValueBasic > 7 then + begin + GetCPUID(7, 0, LReg7_0); + end; + +{$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + +{For best results, we should call the GetEnabledXStateFeatures Windows API function +that gets a mask of enabled XState features on x86 or x64 processors. +This function is implemented starting from Windows 7, so we should use GetProcAddress +Not all features supported by a processor may be enabled on the system. +Using a feature which is not enabled may result in exceptions or undefined behavior. +This is because the operating system would not save the registers and the states between switches. +} + + FGetEnabledXStateFeatures:= GetProcAddress(GetModuleHandle(Kernel32), + 'GetEnabledXStateFeatures'); + if Assigned(FGetEnabledXStateFeatures) then + begin + EnabledXStateFeatures := FGetEnabledXStateFeatures; + end else + begin + EnabledXStateFeatures := + (UnsignedBit shl XSTATE_LEGACY_FLOATING_POINT) or + (UnsignedBit shl XSTATE_LEGACY_SSE); + end; +{$endif} + + GetCPUID(1, 0, LReg1); + + if + ((LReg1.RegEDX and (UnsignedBit shl 26)) <> 0) {SSE2 bit} + then + begin + {If we have SSE2 bit set in the CPUID, than we have the PAUSE + instruction supported, we don't have to check for XState/CR0 for PAUSE, + because PAUSE and other instructions like PREFETCHh, MOVNTI, etc. + work regardless of the CR0 values} + + {$ifndef DisablePauseAndSwitchToThread} + {$ifndef POSIX} + if Assigned(FSwitchToThread) then + {$endif} + begin + {$ifndef AssumePauseAndSwitchToThreadAvailable} + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeaturePauseAndSwitch; + {$endif DisablePauseAndSwitchToThread} + end; + {$endif} + end; + +{$ifdef EnableMMX} + if + ((LReg1.RegEDX and (UnsignedBit shl 23)) <> 0) +{$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + and ((EnabledXStateFeatures and (UnsignedBit shl XSTATE_LEGACY_SSE)) <> 0) +{$endif} + then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureMMX; + end; +{$endif EnableMMX} + +{$ifdef 32bit} + if + ((LReg1.RegEDX and (UnsignedBit shl 25)) <> 0) + {$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + and ((EnabledXStateFeatures and (UnsignedBit shl XSTATE_LEGACY_SSE)) <> 0) + {$endif} + then + begin + {$ifdef 32bit_SSE} + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureSSE; + {$endif} + end; +{$endif 32bit} + +{ Here is the Intel algorithm to detext AVX } +{ QUOTE from the Intel 64 and IA-32 Architectures Optimization Reference Manual +1) Detect CPUID.1:ECX.OSXSAVE[bit 27] = 1 (XGETBV enabled for application use1) +2) Issue XGETBV and verify that XCR0[2:1] = '11b' (XMM state and YMM state are enabled by OS). +3) detect CPUID.1:ECX.AVX[bit 28] = 1 (AVX instructions supported). +ENDQUOTE} + + {$ifdef EnableAVX} + if + ((LReg1.RegECX and (UnsignedBit shl 27)) <> 0) {OSXSAVE bit} then + begin + CpuXCR0 := GetCpuXCR(0); + end else + begin + CpuXCR0 := 0; + end; + {$endif} + + {$ifdef EnableAVX} + if + {verify that XCR0[2:1] = '11b' (XMM state and YMM state are enabled by OS).} + (CpuXCR0 and CXcrXmmAndYmmMask = CXcrXmmAndYmmMask) and + + {verify that CPUID.1:ECX.AVX[bit 28] = 1 (AVX instructions supported)} + ((LReg1.RegECX and (UnsignedBit shl 28)) <> 0) {AVX bit} + + {$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + and ((EnabledXStateFeatures and (cXstateAvx1Mask) = cXstateAvx1Mask)) + {$endif} + + then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureAVX1; + end; + + if (FastMMCpuFeatures and FastMMCpuFeatureAVX1 <> 0) then + begin + { Application Software must identify that hardware supports AVX, after that it must also detect support for AVX2 by + checking CPUID.(EAX=07H, ECX=0H):EBX.AVX2[bit 5].} + if (MaxInputValueBasic > 7) and + ((LReg7_0.RegEBX and (UnsignedBit shl 5))<> 0) then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureAVX2; + + // check for AVX-512 + {$ifdef EnableAVX512} + if + ((CpuXCR0 and CXcrZmmMask) = CXcrZmmMask) and + { Processor support of AVX-512 Foundation instructions is indicated by CPUID.(EAX=07H, ECX=0):EBX.AVX512F[bit16] = 1} + ((LReg7_0.RegEBX and (1 shl 16)) <> 0) + {$ifdef Use_GetEnabledXStateFeatures_WindowsAPICall} + and ((EnabledXStateFeatures and cXstateAvx512Mask) = cXstateAvx512Mask) + {$endif} + then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureAVX512; + end; + {$endif} + + end; + end; + {$endif EnableAVX} + + {$ifdef EnableERMS} + if (MaxInputValueBasic > 7) and +{EBX: Bit 09: Supports Enhanced REP MOVSB/STOSB if 1.} + ((LReg7_0.RegEBX and (UnsignedBit shl 9))<> 0) then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureERMS; + end; + {$endif EnableERMS} + + {$ifdef EnableFSRM} + if (MaxInputValueBasic > 7) and +{EDX: Bit 04: Supports Fast Short REP MOVSB if 1.} + ((LReg7_0.RegEDX and (UnsignedBit shl 4)) <> 0) then + begin + FastMMCpuFeatures := FastMMCpuFeatures or FastMMCpuFeatureFSRM; + end; + {$endif} + end; + + end; +{$endif} + + {Initialize the memory manager} + {-------------Set up the small block types-------------} + + {$ifdef SmallBlocksLockedCriticalSection} + if not CpuFeaturePauseAndSwitch then + begin + for LInd := Low(SmallBlockCriticalSections) to High(SmallBlockCriticalSections) do + begin + {$ifdef fpc}InitCriticalSection{$else}InitializeCriticalSection{$endif}(SmallBlockCriticalSections[LInd]); + end; + end; + {$endif} + + InitializeInvalidMemoryManager; + + InitializeBlockTypeSizes; + + LPreviousBlockSize := 0; + + for LInd := 0 to High(SmallBlockTypes) do + begin + SmallBlockTypes[LInd].SmallBlockTypeLocked := CLockByteAvailable; + + + +{$ifdef UseCustomFixedSizeMoveRoutines} + + {Set the move procedure} + + {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.} + + + {$ifdef 32bit_SSE} + {$ifndef unix} + {$ifdef USE_CPUID} + // if we have SSE, use SSE copy + // even if we have Fast Short REP MOVSB, it is not as fast for sizes below 92 bytes under 32-bit + if ((FastMMCpuFeatures and FastMMCpuFeatureSSE) <> 0) then + begin + case SmallBlockTypes[LInd].BlockSize of + 24: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move20_32bit_SSE; + 32: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move28_32bit_SSE; + 40: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move36_32bit_SSE; + 48: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move44_32bit_SSE; + 56: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move52_32bit_SSE; + 64: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move60_32bit_SSE; + 72: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move68_32bit_SSE; + 80: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move76_32bit_SSE; + 88: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move84_32bit_SSE; + 96: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move92_32bit_SSE; + end; + end; + {$endif} + {$endif} + {$endif} + + if not Assigned(SmallBlockTypes[LInd].UpsizeMoveProcedure) then + begin + case SmallBlockTypes[LInd].BlockSize of + {$ifdef 32bit} + 8: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move4; + {$endif} + {$ifndef Align32Bytes} + 16: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32Bit}Move12{$else}Move8{$endif}; + {$ifndef Align16Bytes} + 24: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32bit}Move20{$else}Move16{$endif}; + {$endif Align16Bytes} + {$endif Align32Bytes} + + 32: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32Bit}Move28{$else}Move24{$endif}; + + {$ifndef Align32Bytes} + {$ifndef Align16Bytes} + 40: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32bit}Move36{$else}Move32{$endif}; + {$endif} + 48: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32Bit}Move44{$else}Move40{$endif}; + {$ifndef Align16Bytes} + 56: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32Bit}Move52{$else}Move48{$endif}; + {$endif} + {$endif} + + 64: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32Bit}Move60{$else}Move56{$endif}; + + {$ifndef Align32Bytes} + {$ifndef Align16Bytes} + 72: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}{$ifdef 32bit}Move68{$else}Move64{$endif}; + {$endif} + {$endif} + end; + end; + + {$ifdef 64bit} + {$ifdef EnableFSRM} + {$ifdef USE_CPUID} + if (FastMMCpuFeatures and FastMMCpuFeatureFSRM) <> 0 then + begin + // don't use any register copy if we have Fast Short REP MOVSB + // Fast Short REP MOVSB is very fast under 64-bit + case SmallBlockTypes[LInd].BlockSize of + {$ifndef Align32Bytes} + 16: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move8; + {$ifndef Align16Bytes} + 24: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move16; + {$endif Align16Bytes} + {$endif Align32Bytes} + 32: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move24Reg64; + {$ifndef Align32Bytes} + {$ifndef Align16Bytes} + 40: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move32Reg64; + {$endif} + 48: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move40Reg64; + {$ifndef Align16Bytes} + 56: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move48Reg64; + {$endif} + {$endif} + 64: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move56Reg64; + else SmallBlockTypes[LInd].UpsizeMoveProcedure := nil; + end; + end; + {$endif} + {$endif} + {$endif} + + +{$ifdef 64Bit} +{$ifdef EnableAVX} + + {$ifdef EnableAVX512} + // if we have AVX-512 but don't have FSRM + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX512) <> 0) + {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} + then + begin + case SmallBlockTypes[LInd].BlockSize of + 32*01: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move24AVX512; + 32*02: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move56AVX512; + 32*03: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move88AVX512; + 32*04: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move120AVX512; + 32*05: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move152AVX512; + 32*06: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move184AVX512; + 32*07: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move216AVX512; + 32*08: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move248AVX512; + 32*09: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move280AVX512; + 32*10: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move312AVX512; + 32*11: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move344AVX512; + end; + end else + {$endif} + {$ifndef DisableAVX2} + // if we have AVX2 but don't have FSRM + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX2) <> 0) + {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} + then + begin + case SmallBlockTypes[LInd].BlockSize of + 32*1: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move24AVX2; + 32*2: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move56AVX2; + 32*3: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move88AVX2; + 32*4: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move120AVX2; + 32*5: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move152AVX2; + 32*6: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move184AVX2; + 32*7: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move216AVX2; + end; + end else + {$endif DisableAVX2} + {$ifndef DisableAVX1} + // if we have AVX1 but don't have FSRM + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX1) <> 0) + {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} + then + begin + case SmallBlockTypes[LInd].BlockSize of + 32*1: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move24AVX1; + 32*2: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move56AVX1; + 32*3: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move88AVX1; + 32*4: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move120AVX1; + 32*5: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move152AVX1; + 32*6: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move184AVX1; + 32*7: SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}Move216AVX1; + end; + end else + {$endif} + begin + // dummy block in case of no AVX code above is defined + end; +{$endif} +{$endif} + + if not Assigned(SmallBlockTypes[LInd].UpsizeMoveProcedure) then + {$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align32Bytes} + {$ifdef EnableAVX} + {We must check AVX1 bit before checking the AVX2 bit} + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX2) <> 0) {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} then + begin + if ((FastMMCpuFeatures and FastMMCpuFeatureERMS) <> 0) {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} then + begin + {$ifdef EnableAVX512} + {$ifndef DisableMoveX32LpAvx512} + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX512) <> 0) {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} then + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := MoveX32LpAvx512WithErms; + end else + {$endif} + {$endif} + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveX32LpAvx2WithErms; + end; + end else + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveX32LpAvx2NoErms; + end; + end else + if ((FastMMCpuFeatures and FastMMCpuFeatureAVX1) <> 0) {$ifdef EnableFSRM}and ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) = 0){$endif} then + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveX32LpAvx1NoErms; + end else + {$endif EnableAVX} + begin + {$ifdef EnableERMS} + if ((FastMMCpuFeatures and FastMMCpuFeatureERMS) <> 0) + {$ifdef EnableFSRM}or ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) <> 0){$endif} + then + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveWithErmsNoAVX; + end else + {$endif} + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveX16LP; + end; + end; + {$else Align32Bytes} + {$ifdef USE_CPUID} + {$ifdef EnableERMS} + if ((FastMMCpuFeatures and FastMMCpuFeatureERMS) <> 0) + {$ifdef EnableFSRM}or ((FastMMCpuFeatures and FastMMCpuFeatureFSRM) <> 0){$endif} + then + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveWithErmsNoAVX; + end + else + {$endif EnableERMS} + {$endif USE_CPUID} + begin + SmallBlockTypes[LInd].UpsizeMoveProcedure := {$ifdef FPC}@{$endif}MoveX16LP + end; + ; + {$endif Align32Bytes} + {$else UseCustomVariableSizeMoveRoutines} + SmallBlockTypes[LInd].UpsizeMoveProcedure := @System.Move; + {$endif UseCustomVariableSizeMoveRoutines} +{$endif} +{$ifdef LogLockContention} + SmallBlockTypes[LInd].BlockCollector.Initialize; +{$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.} + LPSmallBlockType := @(SmallBlockTypes[LInd]); + LPSmallBlockPoolHeader := SmallBlockTypePtrToPoolHeaderPtr(LPSmallBlockType); + SmallBlockTypes[LInd].PreviousPartiallyFreePool := LPSmallBlockPoolHeader; + SmallBlockTypes[LInd].NextPartiallyFreePool := LPSmallBlockPoolHeader; + {Set the block size to block type index translation table} + for LSizeInd := (LPreviousBlockSize div SmallBlockGranularity) to (NativeUInt(SmallBlockTypes[LInd].BlockSize - 1) shr SmallBlockGranularityPowerOf2) do + begin + {$ifdef AllocSize2SmallBlockTypesPrecomputedOffsets} + AllocSz2SmlBlkTypOfsDivSclFctr[LSizeInd] := LInd shl (SmallBlockTypeRecSizePowerOf2 - MaximumCpuScaleFactorPowerOf2); + {$else} + AllocSize2SmallBlockTypesIdx[LSizeInd] := LInd; + {$endif} + end; + {Cannot sequential feed yet: Ensure that the next address is greater than + the maximum address} + SmallBlockTypes[LInd].MaxSequentialFeedBlockAddress := Pointer(0); + SmallBlockTypes[LInd].NextSequentialFeedBlockAddress := Pointer(1); + {Get the mask to use for finding a medium block suitable for a block pool} + LMinimumPoolSize := + ((SmallBlockTypes[LInd].BlockSize * MinimumSmallBlocksPerPool + + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) + and MediumBlockGranularityMask) + MediumBlockSizeOffset; + if LMinimumPoolSize < MinimumMediumBlockSize then + begin + LMinimumPoolSize := MinimumMediumBlockSize; + end; + {Get the closest group number for the minimum pool size} + LGroupNumber := (LMinimumPoolSize - MinimumMediumBlockSize + MediumBlockBinsPerGroup * MediumBlockGranularity div 2) + shr (MediumBlockBinsPerGroupPowerOf2 + MediumBlockGranularityPowerOf2); + {Too large?} + if LGroupNumber > 7 then + begin + LGroupNumber := 7; + end; + + {Set the bitmap} + LByte := Byte(UnsignedBit) shl LGroupNumber; + SmallBlockTypes[LInd].AllowedGroupsForBlockPoolBitmap := NegByteMaskBit(LByte); + {Set the minimum pool size} + SmallBlockTypes[LInd].MinimumBlockPoolSize := MinimumMediumBlockSize + (LGroupNumber shl (MediumBlockGranularityPowerOf2 + MediumBlockBinsPerGroupPowerOf2)); + {Get the optimal block pool size} + LOptimalPoolSize := ((SmallBlockTypes[LInd].BlockSize * TargetSmallBlocksPerPool + + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) + and MediumBlockGranularityMask) + MediumBlockSizeOffset; + {Limit the optimal pool size to within range} + if LOptimalPoolSize < OptimalSmallBlockPoolSizeLowerLimit then + begin + LOptimalPoolSize := OptimalSmallBlockPoolSizeLowerLimit; + end; + if LOptimalPoolSize > OptimalSmallBlockPoolSizeUpperLimit then + begin + LOptimalPoolSize := OptimalSmallBlockPoolSizeUpperLimit; + end; + {How many blocks will fit in the adjusted optimal size?} + LBlocksPerPool := (LOptimalPoolSize - SmallBlockPoolHeaderSize) div SmallBlockTypes[LInd].BlockSize; + {Recalculate the optimal pool size to minimize wastage due to a partial + last block.} + SmallBlockTypes[LInd].OptimalBlockPoolSize := + ((LBlocksPerPool * SmallBlockTypes[LInd].BlockSize + SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset) and MediumBlockGranularityMask) + MediumBlockSizeOffset; +{$ifdef UseReleaseStack} + for LSlot := 0 to NumStacksPerBlock - 1 do + SmallBlockTypes[LInd].ReleaseStack[LSlot].Initialize(ReleaseStackSize, SizeOf(Pointer)); +{$endif} +{$ifdef CheckHeapForCorruption} + {Debug checks} + if (SmallBlockTypes[LInd].OptimalBlockPoolSize < MinimumMediumBlockSize) + or ((SmallBlockTypes[LInd].BlockSize shr SmallBlockGranularityPowerOf2) shl SmallBlockGranularityPowerOf2 <> SmallBlockTypes[LInd].BlockSize) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +{$endif} + {Set the previous small block size} + LPreviousBlockSize := SmallBlockTypes[LInd].BlockSize; + end; + + {-------------------Set up the medium blocks-------------------} + + MediumBlocksLocked := CLockByteAvailable; + {$ifdef MediumBlocksLockedCriticalSection} + {$ifdef fpc}InitCriticalSection{$else}InitializeCriticalSection{$endif}(MediumBlocksLockedCS); + {$endif} + +{$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 MediumBlockGranularityMask) + MediumBlockSizeOffset < MinimumMediumBlockSize then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +{$endif} + {There are currently no medium block pools} + MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + {All medium bins are empty} + for LInd := 0 to High(MediumBlockBins) do + begin + LPMediumFreeBlock := @(MediumBlockBins[LInd]); + LPMediumFreeBlock^.PreviousFreeBlock := LPMediumFreeBlock; + LPMediumFreeBlock^.NextFreeBlock := LPMediumFreeBlock; + end; + {------------------Set up the large blocks---------------------} + LargeBlocksLocked := CLockByteAvailable; + {$ifdef LargeBlocksLockedCriticalSection} + {$ifdef fpc}InitCriticalSection{$else}InitializeCriticalSection{$endif}(LargeBlocksLockedCS); + {$endif} + LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList; + {------------------Set up the debugging structures---------------------} + +{$ifdef EnableMemoryLeakReporting} + ExpectedMemoryLeaksListLocked := CLockByteAvailable; +{$endif} + +{$ifdef FullDebugMode} + {Set up the fake VMT} + {Copy the basic info from the TFreedObject class} + System.Move(Pointer(PByte(TFreedObject) + vmtSelfPtr + SizeOf(Pointer))^, + FreedObjectVMT.VMTData[vmtSelfPtr + SizeOf(Pointer)], vmtParent - vmtSelfPtr); + PNativeUInt(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]); + {Set up the virtual method table} + for LInd := 0 to MaxFakeVMTEntries - 1 do + begin + PNativeUInt(@FreedObjectVMT.VMTMethods[Low(FreedObjectVMT.VMTMethods) + NativeInt(LInd * SizeOf(Pointer))])^ := + NativeUInt(@TFreedObject.GetVirtualMethodIndex) + LInd * VMTIndexIncCodeSize; + {$ifdef CatchUseOfFreedInterfaces} + VMTBadInterface[LInd] := @TFreedObject.InterfaceError; + {$endif} + end; + {Set up the default log file name} +{$endif} +{$ifdef _EventLog} + SetDefaultMMLogFileName; +{$endif} + {Initialize lock contention loggers for medium and large blocks} +{$ifdef LogLockContention} + MediumBlockCollector.Initialize; + LargeBlockCollector.Initialize; +{$endif} + {Initialize release stacks for medium and large blocks} +{$ifdef UseReleaseStack} + for LSlot := 0 to NumStacksPerBlock - 1 do + begin + MediumReleaseStack[LSlot].Initialize(ReleaseStackSize, SizeOf(pointer)); + LargeReleaseStack[LSlot].Initialize(ReleaseStackSize, SizeOf(pointer)); + end; +{$endif} +end; + +{Installs the memory manager (InitializeMemoryManager should be called first)} +procedure InstallMemoryManager; +{$ifdef MMSharingEnabled} +var + i, LCurrentProcessID: Cardinal; + LPMapAddress: PPointer; + LChar: AnsiChar; +{$endif} +begin + {$ifdef fpc} + FillChar(NewMemoryManager, SizeOf(NewMemoryManager), 0); // prevents potential undefined behavior on FPC caused by uninitialized data block + {$endif} + if not FastMMIsInstalled then + begin +{$ifdef FullDebugMode} + {$ifdef 32Bit} + {Try to reserve the 64K block covering address $80808080 so pointers with DebugFillPattern will A/V} + ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS); + {Allocate the address space slack.} + AddressSpaceSlackPtr := VirtualAlloc(nil, FullDebugModeAddressSpaceSlack, MEM_RESERVE or MEM_TOP_DOWN, PAGE_NOACCESS); + {$endif} +{$endif} +{$ifdef MMSharingEnabled} + {Build a string identifying the current process} + LCurrentProcessID := GetCurrentProcessId; + for i := 0 to 7 do + begin + LChar := HexTable[((LCurrentProcessID shr (i * 4)) and $F)]; + MappingObjectName[(High(MappingObjectName) - 1) - i] := LChar; + {$ifdef EnableBackwardCompatibleMMSharing} + UniqueProcessIDString[8 - i] := LChar; + UniqueProcessIDStringBE[8 - i] := LChar; + {$endif} + end; +{$endif} +{$ifdef AttemptToUseSharedMM} + {Is the replacement memory manager already installed for this process?} +{$ifdef EnableBackwardCompatibleMMSharing} + MMWindow := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1])); + MMWindowBE := FindWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1])); +{$endif} + MappingObjectHandle := OpenFileMappingA(FILE_MAP_READ, False, MappingObjectName); + {Is no MM being shared?} +{$ifdef EnableBackwardCompatibleMMSharing} + if (MMWindow or MMWindowBE or MappingObjectHandle) = 0 then +{$else} + if MappingObjectHandle = 0 then +{$endif} + begin +{$endif} +{$ifdef ShareMM} + {Share the MM with other DLLs? - if this DLL is unloaded, then + dependent DLLs will cause a crash.} + {$ifndef ShareMMIfLibrary} + if not IsLibrary then + {$endif} + begin + {$ifdef EnableBackwardCompatibleMMSharing} + {No memory manager installed yet - create the invisible window} + MMWindow := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDString[1]), + WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil); + MMWindowBE := CreateWindowA('STATIC', PAnsiChar(@UniqueProcessIDStringBE[1]), + WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil); + {The window data is a pointer to this memory manager} + if MMWindow <> 0 then + SetWindowLongA(MMWindow, GWL_USERDATA, NativeInt(@NewMemoryManager)); + if MMWindowBE <> 0 then + SetWindowLongA(MMWindowBE, GWL_USERDATA, NativeInt(@NewMemoryManager)); + {$endif} + {Create the memory mapped file} + MappingObjectHandle := CreateFileMappingA(INVALID_HANDLE_VALUE, nil, + PAGE_READWRITE, 0, SizeOf(Pointer), MappingObjectName); + {Map a view of the memory} + LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_WRITE, 0, 0, 0); + {Set a pointer to the new memory manager} + LPMapAddress^ := @NewMemoryManager; + {Unmap the file} + UnmapViewOfFile(LPMapAddress); + end; +{$endif} + {We will be using this memory manager} +{$ifndef FullDebugMode} + NewMemoryManager.GetMem := {$ifdef FPC}@{$endif}FastGetMem; + NewMemoryManager.FreeMem := {$ifdef FPC}@{$endif}FastFreeMem; + NewMemoryManager.ReallocMem := {$ifdef FPC}@{$endif}FastReallocMem; + {$ifdef fpc} + NewMemoryManager.FreememSize := {$ifdef FPC}@{$endif}FastFreeMemSize; + NewMemoryManager.AllocMem := {$ifdef FPC}@{$endif}FastAllocMem; + NewMemoryManager.MemSize := {$ifdef FPC}@{$endif}FastMemSize; + {$endif} +{$else} + NewMemoryManager.GetMem := {$ifdef FPC}@{$endif}DebugGetMem; + NewMemoryManager.FreeMem := {$ifdef FPC}@{$endif}DebugFreeMem; + NewMemoryManager.ReallocMem := {$ifdef FPC}@{$endif}DebugReallocMem; +{$endif} +{$ifdef fpc} + NewMemoryManager.GetFPCHeapStatus := {$ifdef FPC}@{$endif}FastGetFPCHeapStatus; //support get TFPCHeapStatus +{$endif} +{$ifdef BDS2006AndUp} + {$ifndef FullDebugMode} + NewMemoryManager.AllocMem := {$ifdef FPC}@{$endif}FastAllocMem; + {$else} + NewMemoryManager.AllocMem := {$ifdef FPC}@{$endif}DebugAllocMem; + {$endif} + {$ifdef EnableMemoryLeakReporting} + NewMemoryManager.RegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}RegisterExpectedMemoryLeak; + NewMemoryManager.UnRegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}UnRegisterExpectedMemoryLeak; + {$else} + NewMemoryManager.RegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}NoOpRegisterExpectedMemoryLeak; + NewMemoryManager.UnRegisterExpectedMemoryLeak := {$ifdef FPC}@{$endif}NoOpUnRegisterExpectedMemoryLeak; + {$endif} +{$endif} + {Owns the memory manager} + IsMemoryManagerOwner := True; +{$ifdef AttemptToUseSharedMM} + end + else + begin + {Get the address of the shared memory manager} + {$ifndef BDS2006AndUp} + {$ifdef EnableBackwardCompatibleMMSharing} + if MappingObjectHandle <> 0 then + begin + {$endif} + {Map a view of the memory} + LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0); + {Set the new memory manager} + NewMemoryManager := PMemoryManager(LPMapAddress^)^; + {Unmap the file} + UnmapViewOfFile(LPMapAddress); + {$ifdef EnableBackwardCompatibleMMSharing} + end + else + begin + if MMWindow <> 0 then + begin + NewMemoryManager := PMemoryManager(GetWindowLong(MMWindow, GWL_USERDATA))^; + end + else + begin + NewMemoryManager := PMemoryManager(GetWindowLong(MMWindowBE, GWL_USERDATA))^; + end; + end; + {$endif} + {$else} + {$ifdef EnableBackwardCompatibleMMSharing} + if MappingObjectHandle <> 0 then + begin + {$endif} + {Map a view of the memory} + LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_READ, 0, 0, 0); + {Set the new memory manager} + NewMemoryManager := PMemoryManagerEx(LPMapAddress^)^; + {Unmap the file} + UnmapViewOfFile(LPMapAddress); + {$ifdef EnableBackwardCompatibleMMSharing} + end + else + begin + if MMWindow <> 0 then + begin + NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindow, GWL_USERDATA))^; + end + else + begin + NewMemoryManager := PMemoryManagerEx(GetWindowLong(MMWindowBE, GWL_USERDATA))^; + end; + end; + {$endif} + {$endif} + {Close the file mapping handle} + CloseHandle(MappingObjectHandle); + MappingObjectHandle := 0; + {The memory manager is not owned by this module} + IsMemoryManagerOwner := False; + end; +{$endif} + {Save the old memory manager} + GetMemoryManager(OldMemoryManager); + {Replace the memory manager with either this one or the shared one.} + SetMemoryManager(NewMemoryManager); + {FastMM is now installed} + FastMMIsInstalled := True; +{$ifdef UseOutputDebugString} + if IsMemoryManagerOwner then + OutputDebugStringA(FastMMInstallMsg) + else + OutputDebugStringA(FastMMInstallSharedMsg); +{$endif} + end; +end; + +procedure UninstallMemoryManager; +begin + {Is this the owner of the shared MM window?} + if IsMemoryManagerOwner then + begin +{$ifdef ShareMM} + {$ifdef EnableBackwardCompatibleMMSharing} + {Destroy the window} + if MMWindow <> 0 then + begin + DestroyWindow(MMWindow); + MMWindow := 0; + end; + if MMWindowBE <> 0 then + begin + DestroyWindow(MMWindowBE); + MMWindowBE := 0; + end; + {$endif} + {Destroy the memory mapped file handle} + if MappingObjectHandle <> 0 then + begin + CloseHandle(MappingObjectHandle); + MappingObjectHandle := 0; + end; +{$endif} +{$ifdef FullDebugMode} + {Release the reserved block} + if ReservedBlock <> nil then + begin + VirtualFree(ReservedBlock, 0, MEM_RELEASE); + ReservedBlock := nil; + end; + {Release the address space slack} + if AddressSpaceSlackPtr <> nil then + begin + VirtualFree(AddressSpaceSlackPtr, 0, MEM_RELEASE); + AddressSpaceSlackPtr := nil; + end; +{$endif} + end; +{$ifndef DetectMMOperationsAfterUninstall} + {Restore the old memory manager} + SetMemoryManager(OldMemoryManager); +{$else} + {Set the invalid memory manager: no more MM operations allowed} + SetMemoryManager(InvalidMemoryManager); +{$endif} + {Memory manager has been uninstalled} + FastMMIsInstalled := False; +{$ifdef UseOutputDebugString} + if IsMemoryManagerOwner then + OutputDebugStringA(FastMMUninstallMsg) + else + OutputDebugStringA(FastMMUninstallSharedMsg); +{$endif} +end; + +{$ifdef UseReleaseStack} +procedure CleanupReleaseStacks; +var + LInd: Integer; + LMemory: Pointer; + LSlot: Integer; +begin + for LInd := 0 to High(SmallBlockTypes) do begin + for LSlot := 0 to NumStacksPerBlock-1 do + while SmallBlockTypes[LInd].ReleaseStack[LSlot].Pop(LMemory) do + FastFreeMem(LMemory); + {Finalize all stacks only after all memory for this block has been freed.} + {Otherwise, FastFreeMem could try to access a stack that was already finalized.} + for LSlot := 0 to NumStacksPerBlock-1 do + SmallBlockTypes[LInd].ReleaseStack[LSlot].Finalize; + end; + for LSlot := 0 to NumStacksPerBlock-1 do + begin + while MediumReleaseStack[LSlot].Pop(LMemory) do + FastFreeMem(LMemory); + while LargeReleaseStack[LSlot].Pop(LMemory) do + FastFreeMem(LMemory); + end; + for LSlot := 0 to NumStacksPerBlock-1 do + begin + MediumReleaseStack[LSlot].Finalize; + LargeReleaseStack[LSlot].Finalize; + end; +end; + +function ReleaseStackCleanupThreadProc(AParam: Pointer): Integer; +var + LMemBlock: Pointer; + LSlot: Integer; +begin + {Clean up 1 medium and 1 large block for every thread slot, every 100ms.} + while WaitForSingleObject(ReleaseStackCleanupThreadTerminate, 100) = WAIT_TIMEOUT do + begin + for LSlot := 0 to NumStacksPerBlock - 1 do + begin + if (not MediumReleaseStack[LSlot].IsEmpty) + and (AcquireLockByte(MediumBlocksLocked)) then + begin + if MediumReleaseStack[LSlot].Pop(LMemBlock) then + FreeMediumBlock(LMemBlock, True) + else + begin + UnlockMediumBlocks; + end; + end; + if (not LargeReleaseStack[LSlot].IsEmpty) + and (AcquireLockByte(LargeBlocksLocked)) then + begin + if LargeReleaseStack[LSlot].Pop(LMemBlock) then + FreeLargeBlock(LMemBlock, True) + else + begin + UnlockLargeBlocks; + end; + end; + end; + end; + Result := 0; +end; + +procedure CreateCleanupThread; +var + LThreadID: DWORD; +begin + ReleaseStackCleanupThreadTerminate := CreateEvent(nil, False, False, nil); + if ReleaseStackCleanupThreadTerminate = 0 then + {$ifdef BCB6OrDelphi7AndUp}System.Error(reInvalidPtr);{$else}System.RunError(reInvalidPtr);{$endif} + ReleaseStackCleanupThread := BeginThread(nil, 0, ReleaseStackCleanupThreadProc, nil, 0, LThreadID); + if ReleaseStackCleanupThread = 0 then + {$ifdef BCB6OrDelphi7AndUp}System.Error(reInvalidPtr);{$else}System.RunError(reInvalidPtr);{$endif} + SetThreadPriority(ReleaseStackCleanupThread, THREAD_PRIORITY_LOWEST); +end; + +procedure DestroyCleanupThread; +begin + if ReleaseStackCleanupThread <> 0 then + begin + SetEvent(ReleaseStackCleanupThreadTerminate); + WaitForSingleObject(ReleaseStackCleanupThread, INFINITE); + CloseHandle(ReleaseStackCleanupThread); + ReleaseStackCleanupThread := 0; + CloseHandle(ReleaseStackCleanupThreadTerminate); + ReleaseStackCleanupThreadTerminate := 0; + end; +end; +{$endif} + +procedure FinalizeMemoryManager; +{$ifdef SmallBlocksLockedCriticalSection} +var + LInd: Integer; +{$endif} +begin + {Restore the old memory manager if FastMM has been installed} + if FastMMIsInstalled then + begin +{$ifdef UseReleaseStack} + DestroyCleanupThread; + CleanupReleaseStacks; +{$endif} +{$ifndef NeverUninstall} + {Uninstall FastMM} + UninstallMemoryManager; +{$endif} + {Do we own the memory manager, or are we just sharing it?} + if IsMemoryManagerOwner then + begin +{$ifdef CheckUseOfFreedBlocksOnShutdown} + CheckBlocksOnShutdown( + {$ifdef EnableMemoryLeakReporting} + True + {$ifdef RequireIDEPresenceForLeakReporting} + and DelphiIsRunning + {$endif} + {$ifdef RequireDebuggerPresenceForLeakReporting} + and ((DebugHook <> 0) + {$ifdef PatchBCBTerminate} + or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0)) + {$endif PatchBCBTerminate} + ) + {$endif} + {$ifdef ManualLeakReportingControl} + and ReportMemoryLeaksOnShutdown + {$endif} + {$else} + False + {$endif} + ); +{$else} + {$ifdef EnableMemoryLeakReporting} + if True + {$ifdef RequireIDEPresenceForLeakReporting} + and DelphiIsRunning + {$endif} + {$ifdef RequireDebuggerPresenceForLeakReporting} + {$ifndef fpc} + and ((DebugHook <> 0) + {$ifdef PatchBCBTerminate} + or (Assigned(pCppDebugHook) and (pCppDebugHook^ <> 0)) + {$endif PatchBCBTerminate} + ) + {$endif} + {$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} +{$ifdef LogLockContention} + ReportLockContention; +{$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; + + {$ifdef MediumBlocksLockedCriticalSection} + LargeBlocksLocked := CLockByteFinished; + {$ifdef fpc}DoneCriticalSection{$else}DeleteCriticalSection{$endif}(MediumBlocksLockedCS); + {$endif MediumBlocksLockedCriticalSection} + + {$ifdef LargeBlocksLockedCriticalSection} + LargeBlocksLocked := CLockByteFinished; + {$ifdef fpc}DoneCriticalSection{$else}DeleteCriticalSection{$endif}(LargeBlocksLockedCS); + {$endif LargeBlocksLockedCriticalSection} + + {$ifdef SmallBlocksLockedCriticalSection} + if not CpuFeaturePauseAndSwitch then + begin + for LInd := Low(SmallBlockCriticalSections) to High(SmallBlockCriticalSections) do + begin + {$ifdef fpc}DoneCriticalSection{$else}DeleteCriticalSection{$endif}(SmallBlockCriticalSections[LInd]); + end; + end; + + for LInd := Low(SmallBlockTypes) to High(SmallBlockTypes) do + begin + SmallBlockTypes[LInd].SmallBlockTypeLocked := CLockByteFinished; + end; + {$endif} + + end; +end; + +{$ifdef DEBUG} +procedure SelfTest; +begin +{$ifdef NeedFindFirstSetBit} + if + (FindFirstSetBit(0) <> 0) or + (FindFirstSetBit(1) <> 0) or + (FindFirstSetBit(2) <> 1) or + (FindFirstSetBit(3) <> 0) or + (FindFirstSetBit(4) <> 2) or + (FindFirstSetBit($80000000) <> 31) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; +{$endif} + if (NegByteMaskBit(0) <> 0) or + (NegByteMaskBit(1) <> $FF) or + (NegByteMaskBit(2) <> $FE) or + (NegByteMaskBit(3) <> $FD) or + (NegByteMaskBit(4) <> $FC) or + (NegByteMaskBit($7E) <> $82) or + (NegByteMaskBit($7F) <> $81) or + (NegByteMaskBit($80) <> $80) or + (NegByteMaskBit($81) <> $7F) or + (NegByteMaskBit($FE) <> 2) or + (NegByteMaskBit($FF) <> 1) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + + if (NegCardinalMaskBit(0) <> 0) or + (NegCardinalMaskBit(1) <> $FFFFFFFF) or + (NegCardinalMaskBit(2) <> $FFFFFFFE) or + (NegCardinalMaskBit(3) <> $FFFFFFFD) or + (NegCardinalMaskBit(4) <> $FFFFFFFC) or + (NegCardinalMaskBit($7E) <> $FFFFFF82) or + (NegCardinalMaskBit($7F) <> $FFFFFF81) or + (NegCardinalMaskBit($80) <> $FFFFFF80) or + (NegCardinalMaskBit($81) <> $FFFFFF7F) or + (NegCardinalMaskBit($FE) <> $FFFFFF02) or + (NegCardinalMaskBit($FF) <> $FFFFFF01) or + (NegCardinalMaskBit($100) <> $FFFFFF00) or + (NegCardinalMaskBit($101) <> $FFFFFEFF) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + + if + (NegCardinalMaskBit($7FFFFFFF) <> $80000001) or + (NegCardinalMaskBit($80000000) <> $80000000) or + (NegCardinalMaskBit($80000001) <> $7FFFFFFF) or + (NegCardinalMaskBit($FFFFFFFF) <> 1) or + (NegCardinalMaskBit($FFFFFFFE) <> 2) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + + {$ifdef 32bit} + if (NegNativeUintMaskBit(0) <> 0) or + (NegNativeUintMaskBit(1) <> $FFFFFFFF) or + (NegNativeUintMaskBit(2) <> $FFFFFFFE) or + (NegNativeUintMaskBit(3) <> $FFFFFFFD) or + (NegNativeUintMaskBit(4) <> $FFFFFFFC) or + (NegNativeUintMaskBit($7E) <> $FFFFFF82) or + (NegNativeUintMaskBit($7F) <> $FFFFFF81) or + (NegNativeUintMaskBit($80) <> $FFFFFF80) or + (NegNativeUintMaskBit($81) <> $FFFFFF7F) or + (NegNativeUintMaskBit($FE) <> $FFFFFF02) or + (NegNativeUintMaskBit($FF) <> $FFFFFF01) or + (NegNativeUintMaskBit($100) <> $FFFFFF00) or + (NegNativeUintMaskBit($101) <> $FFFFFEFF) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + if + (NegNativeUintMaskBit($7FFFFFFF) <> $80000001) or + (NegNativeUintMaskBit($80000000) <> $80000000) or + (NegNativeUintMaskBit($80000001) <> $7FFFFFFF) or + (NegNativeUintMaskBit($FFFFFFFF) <> 1) or + (NegNativeUintMaskBit($FFFFFFFE) <> 2) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + {$else 32bit} + if (NegNativeUintMaskBit(0) <> 0) or + (NegNativeUintMaskBit(1) <> $FFFFFFFFFFFFFFFF) or + (NegNativeUintMaskBit(2) <> $FFFFFFFFFFFFFFFE) or + (NegNativeUintMaskBit(3) <> $FFFFFFFFFFFFFFFD) or + (NegNativeUintMaskBit(4) <> $FFFFFFFFFFFFFFFC) or + (NegNativeUintMaskBit($7E) <> $FFFFFFFFFFFFFF82) or + (NegNativeUintMaskBit($7F) <> $FFFFFFFFFFFFFF81) or + (NegNativeUintMaskBit($80) <> $FFFFFFFFFFFFFF80) or + (NegNativeUintMaskBit($81) <> $FFFFFFFFFFFFFF7F) or + (NegNativeUintMaskBit($FE) <> $FFFFFFFFFFFFFF02) or + (NegNativeUintMaskBit($FF) <> $FFFFFFFFFFFFFF01) or + (NegNativeUintMaskBit($100) <> $FFFFFFFFFFFFFF00) or + (NegNativeUintMaskBit($101) <> $FFFFFFFFFFFFFEFF) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + if + (NegNativeUintMaskBit($7FFFFFFF) <> $FFFFFFFF80000001) or + (NegNativeUintMaskBit($80000000) <> $FFFFFFFF80000000) or + (NegNativeUintMaskBit($80000001) <> $FFFFFFFF7FFFFFFF) or + (NegNativeUintMaskBit($FFFFFFFF) <> $FFFFFFFF00000001) or + (NegNativeUintMaskBit($FFFFFFFE) <> $FFFFFFFF00000002) or + (NegNativeUintMaskBit($FFFFFFFFFFFFFFFF) <> 1) or + (NegNativeUintMaskBit($FFFFFFFFFFFFFFFE) <> 2) then + begin + {$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); + {$else} + System.RunError(reInvalidPtr); + {$endif} + end; + {$endif 32bit} +end; +{$endif} + +procedure RunInitializationCode; +begin + {Only run this code once during startup.} + if InitializationCodeHasRun then + Exit; + InitializationCodeHasRun := True; +{$ifndef BCB} +{$ifdef DEBUG} + SelfTest; +{$endif} + {$ifdef InstallOnlyIfRunningInIDE} + if (DebugHook <> 0) and DelphiIsRunning then + {$endif} + begin + {Initialize all the lookup tables, etc. for the memory manager} + InitializeMemoryManager; + {Has another MM been set, or has the Embarcadero MM been used? If so, this + file is not the first unit in the uses clause of the project's .dpr + file.} + if CheckCanInstallMemoryManager then + begin + {$ifdef ClearLogFileOnStartup} + DeleteEventLog; + {$endif} + InstallMemoryManager; + end; + {$ifdef UseReleaseStack} + {Release stack mechanism needs a cleanup thread} + CreateCleanupThread; + {$endif} + end; +{$endif} +end; +initialization + RunInitializationCode; +finalization +{$ifndef PatchBCBTerminate} + FinalizeMemoryManager; +{$endif} + +end. diff --git a/contrib/FastMM4-AVX/FastMM4DataCollector.pas b/contrib/FastMM4-AVX/FastMM4DataCollector.pas new file mode 100644 index 0000000..e8dc77c --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4DataCollector.pas @@ -0,0 +1,404 @@ +unit FastMM4DataCollector; + +{$I FastMM4Options.inc} + +interface + +type + TStaticCollector = record + strict private const + CDefaultPromoteGen1_sec = 1; // promote every second + CDefaultPromoteGen1Count = 1; // promote allocations with Count > 1 + CGeneration1Size = 1024; + CGeneration2Size = 256; + CCollectedDataSize = CGeneration2Size; + CMaxPointers = 11; // same as in FastMM4 + public type + TPointers = record + Pointers: array [1..CMaxPointers] of Pointer; + Count : integer; + class operator Equal(const a, b: TPointers): boolean; + end; + TDataInfo = record + Data : TPointers; + Count: integer; + end; + TCollectedData = array [1..CCollectedDataSize] of TDataInfo; + TGenerationOverflowCount = record + Generation1: integer; + Generation2: integer; + end; + strict private type + PDataInfo = ^TDataInfo; + TGenerationPlaceholder = array [1..1] of TDataInfo; + PGenerationPlaceholder = ^TGenerationPlaceholder; + TGenerationInfo = record + Data : PGenerationPlaceholder; + Size : integer; + Last : integer; + NextGeneration : integer; + PromoteEvery_sec: integer; + PromoteCountOver: integer; + OverflowCount : integer; + LastCheck_ms : int64; + end; + var + FGeneration1 : array [1..CGeneration1Size] of TDataInfo; + FGeneration2 : array [1..CGeneration2Size] of TDataInfo; + FGenerationInfo: array [0..2] of TGenerationInfo; //gen0 is used for merging + FLocked : ByteBool; + FPadding : array [1..3] of byte; + function GetGen1_PromoteCountOver: integer; + function GetGen1_PromoteEvery_sec: integer; + function GetOverflowCount: TGenerationOverflowCount; + procedure Lock; + function Now_ms: int64; inline; + procedure SetGen1_PromoteCountOver(const value: integer); + procedure SetGen1_PromoteEvery_sec(const value: integer); + private + procedure AddToGeneration(generation: integer; const aData: TPointers; + count: integer = 1); + procedure CheckPromoteGeneration(generation: integer); inline; + function FindInGeneration(generation: integer; const aData: TPointers): integer; inline; + function FindInsertionPoint(generation, count: integer): integer; inline; + procedure FlushAllGenerations; + function InsertIntoGeneration(generation: integer; const dataInfo: TDataInfo): boolean; + procedure PromoteGeneration(oldGen, newGen: integer); + procedure ResortGeneration(generation, idxData: integer); + public + procedure Initialize; + procedure Add(const pointers: pointer; count: integer); + procedure GetData(var data: TCollectedData; var count: integer); + procedure Merge(var mergedData: TCollectedData; var mergedCount: integer; + const newData: TCollectedData; newCount: integer); + property Gen1_PromoteCountOver: integer read GetGen1_PromoteCountOver + write SetGen1_PromoteCountOver; + property OverflowCount: TGenerationOverflowCount read GetOverflowCount; + property Gen1_PromoteEvery_sec: integer read GetGen1_PromoteEvery_sec write + SetGen1_PromoteEvery_sec; + end; + PStaticCollector = ^TStaticCollector; + +implementation + +uses + Winapi.Windows; //used in Now_ms + +{$RANGECHECKS OFF} + +type + PByteBool = ^ByteBool; + +// Copied from FastMM4.pas +function LockCmpxchg8(CompareVal, NewVal: ByteBool; AAddress: PByteBool): ByteBool; +asm +{$if SizeOf(Pointer) = 4} + {On entry: + al = CompareVal, + dl = NewVal, + ecx = AAddress} + {$ifndef LINUX} + lock cmpxchg [ecx], dl + {$else} + {Workaround for Kylix compiler bug} + db $F0, $0F, $B0, $11 + {$endif} +{$else} + {On entry: + cl = CompareVal + dl = NewVal + r8 = AAddress} + .noframe + mov rax, rcx + lock cmpxchg [r8], dl +{$ifend} +end; + +{ TStaticCollector.TPointers } + +class operator TStaticCollector.TPointers.Equal(const a, b: TPointers): boolean; +var + i: integer; +begin + Result := a.Count = b.Count; + if Result then + for i := 1 to a.Count do + if a.Pointers[i] <> b.Pointers[i] then + Exit(false); +end; + +{ TStaticCollector } + +procedure TStaticCollector.Add(const pointers: pointer; count: integer); +var + ptrData: TPointers; +begin + Lock; + ptrData.Count := CMaxPointers; + if count < CMaxPointers then + ptrData.Count := count; + Move(pointers^, ptrData.Pointers[1], ptrData.Count * SizeOf(pointer)); + AddToGeneration(1, ptrData); + FLocked := false; +end; + +procedure TStaticCollector.AddToGeneration(generation: integer; const aData: TPointers; + count: integer = 1); +var + dataInfo: TDataInfo; + idxData : integer; +begin + CheckPromoteGeneration(generation); + + with FGenerationInfo[generation] do begin + idxData := FindInGeneration(generation, aData); + if idxData >= 1 then begin + Data^[idxData].Count := Data^[idxData].Count + count; + ResortGeneration(generation, idxData); + end + else begin + dataInfo.Data := aData; + dataInfo.Count := count; + InsertIntoGeneration(generation, dataInfo); + end; + end; +end; { TStaticCollector.AddToGeneration } + +procedure TStaticCollector.CheckPromoteGeneration(generation: integer); +begin + with FGenerationInfo[generation] do begin + if NextGeneration > 0 then begin + if LastCheck_ms = 0 then + LastCheck_ms := Now_ms + else if ((Now_ms - LastCheck_ms) div 1000) >= PromoteEvery_sec then begin + PromoteGeneration(generation, NextGeneration); + LastCheck_ms := Now_ms; + end; + end; + end; +end; + +function TStaticCollector.FindInGeneration(generation: integer; const aData: TPointers): + integer; +begin + with FGenerationInfo[generation] do begin + for Result := 1 to Last do + if Data^[Result].Data = aData then + Exit; + end; + Result := 0; +end; + +function TStaticCollector.FindInsertionPoint(generation, count: integer): integer; +var + insert: integer; +begin + with FGenerationInfo[generation] do begin + for insert := Last downto 1 do begin + if Data^[insert].Count > count then + Exit(insert+1); + end; + Result := 1; + end; +end; + +procedure TStaticCollector.FlushAllGenerations; +var + generation: integer; + nextGen : integer; +begin + generation := 1; + while generation <> 0 do begin + nextGen := FGenerationInfo[generation].NextGeneration; + if nextGen > 0 then + PromoteGeneration(generation, nextGen); + generation := nextGen; + end; +end; + +procedure TStaticCollector.GetData(var data: TCollectedData; var count: integer); +begin + Lock; + FlushAllGenerations; + Assert(Length(data) = Length(FGeneration2)); + count := FGenerationInfo[2].Last; + Move(FGeneration2[1], data[1], count * SizeOf(data[1])); + FLocked := false; +end; + +function TStaticCollector.GetGen1_PromoteCountOver: integer; +begin + Result := FGenerationInfo[1].PromoteCountOver; +end; + +function TStaticCollector.GetGen1_PromoteEvery_sec: integer; +begin + Result := FGenerationInfo[1].PromoteEvery_sec; +end; + +function TStaticCollector.GetOverflowCount: TGenerationOverflowCount; +begin + Result.Generation1 := FGenerationInfo[1].OverflowCount; + Result.Generation2 := FGenerationInfo[2].OverflowCount; +end; + +procedure TStaticCollector.Initialize; +begin + Assert(SizeOf(TStaticCollector) mod SizeOf(pointer) = 0); + with FGenerationInfo[1] do begin + Data := PGenerationPlaceholder(@FGeneration1); + Size := CGeneration1Size; + Last := 0; + NextGeneration := 2; + PromoteEvery_sec := CDefaultPromoteGen1_sec; + PromoteCountOver := CDefaultPromoteGen1Count; + LastCheck_ms := 0; + end; + with FGenerationInfo[2] do begin + Data := PGenerationPlaceholder(@FGeneration2); + Size := CGeneration2Size; + NextGeneration := 0; + end; +end; + +function TStaticCollector.InsertIntoGeneration(generation: integer; const dataInfo: + TDataInfo): boolean; +var + idx: integer; +begin + // We already know that this element does not exist in the generation. + + Result := true; + with FGenerationInfo[generation] do begin + idx := FindInsertionPoint(generation, dataInfo.Count); + if idx > Last then begin + if Last = Size then begin + Inc(OverflowCount); + Result := false; + end + else begin + Inc(Last); + Data^[Last] := dataInfo; + end; + end + else begin + if Last < Size then begin + Move(Data^[idx], Data^[idx+1], (Last-idx+1) * SizeOf(Data^[idx])); + Inc(Last); + end + else begin + if Last > idx then + Move(Data^[idx], Data^[idx+1], (Last-idx) * SizeOf(Data^[idx])); + Inc(OverflowCount); + end; + Data^[idx] := dataInfo; + end; + end; +end; + +procedure TStaticCollector.Lock; +begin +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + while LockCmpxchg8(False, True, @FLocked) <> False do + begin +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} + Sleep(0); + if LockCmpxchg8(False, True, @FLocked) = False then + Break; + Sleep(1); +{$endif} + end; + end; +end; + +procedure TStaticCollector.Merge(var mergedData: TCollectedData; + var mergedCount: integer; const newData: TCollectedData; newCount: integer); +var + iNew: integer; +begin + // Merges two sorted arrays. + + FGenerationInfo[0].Data := PGenerationPlaceholder(@mergedData); + FGenerationInfo[0].Last := mergedCount; + FGenerationInfo[0].Size := CCollectedDataSize; + FGenerationInfo[0].NextGeneration := 0; + + for iNew := 1 to newCount do + AddToGeneration(0, newData[iNew].Data, newData[iNew].Count); + + mergedCount := FGenerationInfo[0].Last; +end; + +function TStaticCollector.Now_ms: int64; +var + st: TSystemTime; +begin + // We cannot use SysUtils as that gets memory allocator called before FastMM is initialized. + GetSystemTime(st); + SystemTimeToFileTime(st, TFileTime(Result)); + Result := Result div 10000; +end; + +procedure TStaticCollector.PromoteGeneration(oldGen, newGen: integer); +var + canInsert : boolean; + idxNew : integer; + idxOld : integer; + newGenData: PGenerationPlaceholder; + pOldData : PDataInfo; +begin + canInsert := true; + newGenData := FGenerationInfo[newGen].Data; + with FGenerationInfo[oldGen] do begin + for idxOld := 1 to Last do begin + pOldData := @Data^[idxOld]; + if pOldData^.Count <= PromoteCountOver then + break; //for idxOld + idxNew := FindInGeneration(newGen, pOldData^.Data); + if idxNew > 0 then begin + newGenData^[idxNew].Count := newGenData^[idxNew].Count + pOldData^.Count; + ResortGeneration(newGen, idxNew); + end + else if canInsert then + canInsert := InsertIntoGeneration(newGen, pOldData^) + else with FGenerationInfo[newGen] do + Inc(OverflowCount); + end; //for idxOld + Last := 0; + end; +end; + +procedure TStaticCollector.ResortGeneration(generation, idxData: integer); +var + dataInfo: TDataInfo; + idx : integer; +begin + // Data^[idxData].Count was just updated, resort the generation. + with FGenerationInfo[generation] do begin + idx := FindInsertionPoint(generation, Data^[idxData].Count); + if idx < idxData then begin + dataInfo := Data^[idxData]; + Move(Data^[idx], Data^[idx+1], (idxData-idx) * SizeOf(Data^[idx])); + Data^[idx] := dataInfo; + end; + end; +end; + +procedure TStaticCollector.SetGen1_PromoteCountOver(const value: integer); +begin + FGenerationInfo[1].PromoteCountOver := value; +end; + +procedure TStaticCollector.SetGen1_PromoteEvery_sec(const value: integer); +begin + FGenerationInfo[1].PromoteEvery_sec := value; +end; + +end. diff --git a/contrib/FastMM4-AVX/FastMM4LockFreeStack.pas b/contrib/FastMM4-AVX/FastMM4LockFreeStack.pas new file mode 100644 index 0000000..60d5395 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4LockFreeStack.pas @@ -0,0 +1,352 @@ +// Based on TOmniBaseBoundedStack class from the OmniThreadLibrary, +// originally written by GJ and Primoz Gabrijelcic. + +unit FastMM4LockFreeStack; + +interface + +type + PReferencedPtr = ^TReferencedPtr; + TReferencedPtr = record + PData : pointer; + Reference: NativeInt; + end; + + PLinkedData = ^TLinkedData; + TLinkedData = packed record + Next: PLinkedData; + Data: record end; //user data, variable size + end; + + TLFStack = record + strict private + FDataBuffer : pointer; + FElementSize : integer; + FNumElements : integer; + FPublicChainP : PReferencedPtr; + FRecycleChainP: PReferencedPtr; + class var + class var obsIsInitialized: boolean; //default is false + class var obsTaskPopLoops : NativeInt; + class var obsTaskPushLoops: NativeInt; + class function PopLink(var chain: TReferencedPtr): PLinkedData; static; + class procedure PushLink(const link: PLinkedData; var chain: TReferencedPtr); static; + procedure MeasureExecutionTimes; + public + procedure Empty; + procedure Initialize(numElements, elementSize: integer); + procedure Finalize; + function IsEmpty: boolean; inline; + function IsFull: boolean; inline; + function Pop(var value): boolean; + function Push(const value): boolean; + property ElementSize: integer read FElementSize; + property NumElements: integer read FNumElements; + end; + +implementation + +uses + Windows; + +{$IF CompilerVersion < 23} +{$IFNDEF CPUX64} +type + NativeInt = integer; + NativeUInt = cardinal; +{$ENDIF} +{$IFEND} + +var + CASAlignment: integer; //required alignment for the CAS function - 8 or 16, depending on the platform + +function RoundUpTo(value: pointer; granularity: integer): pointer; +begin + Result := pointer((((NativeInt(value) - 1) div granularity) + 1) * granularity); +end; + +function GetCPUTimeStamp: int64; +asm + rdtsc +{$IFDEF CPUX64} + shl rdx, 32 + or rax, rdx +{$ENDIF CPUX64} +end; + +function GetThreadId: NativeInt; +//result := GetCurrentThreadId; +asm +{$IFNDEF CPUX64} + mov eax, fs:[$18] //eax := thread information block + mov eax, [eax + $24] //eax := thread id +{$ELSE CPUX64} + mov rax, gs:[abs $30] + mov eax, [rax + $48] +{$ENDIF CPUX64} +end; + +function CAS(const oldValue, newValue: NativeInt; var destination): boolean; overload; +asm +{$IFDEF CPUX64} + mov rax, oldValue +{$ENDIF CPUX64} + lock cmpxchg [destination], newValue + setz al +end; + +function CAS(const oldValue, newValue: pointer; var destination): boolean; overload; +asm +{$IFDEF CPUX64} + mov rax, oldValue +{$ENDIF CPUX64} + lock cmpxchg [destination], newValue + setz al +end; + +function CAS(const oldData: pointer; oldReference: NativeInt; newData: pointer; + newReference: NativeInt; var destination): boolean; overload; +asm +{$IFNDEF CPUX64} + push edi + push ebx + mov ebx, newData + mov ecx, newReference + mov edi, destination + lock cmpxchg8b qword ptr [edi] + pop ebx + pop edi +{$ELSE CPUX64} + .noframe + push rbx //rsp := rsp - 8 ! + mov rax, oldData + mov rbx, newData + mov rcx, newReference + mov r8, [destination + 8] //+8 with respect to .noframe + lock cmpxchg16b [r8] + pop rbx +{$ENDIF CPUX64} + setz al +end; + +{ TLFStack } + +procedure TLFStack.Empty; +var + linkedData: PLinkedData; +begin + repeat + linkedData := PopLink(FPublicChainP^); + if not assigned(linkedData) then + break; //repeat + PushLink(linkedData, FRecycleChainP^); + until false; +end; + +procedure TLFStack.Finalize; +begin + HeapFree(GetProcessHeap, 0, FDataBuffer); +end; + +procedure TLFStack.Initialize(numElements, elementSize: integer); +var + bufferElementSize : integer; + currElement : PLinkedData; + dataBuffer : pointer; + iElement : integer; + nextElement : PLinkedData; + roundedElementSize: integer; +begin + Assert(SizeOf(NativeInt) = SizeOf(pointer)); + Assert(numElements > 0); + Assert(elementSize > 0); + FNumElements := numElements; + FElementSize := elementSize; + //calculate element size, round up to next aligned value + roundedElementSize := (elementSize + SizeOf(pointer) - 1) AND NOT (SizeOf(pointer) - 1); + //calculate buffer element size, round up to next aligned value + bufferElementSize := ((SizeOf(TLinkedData) + roundedElementSize) + SizeOf(pointer) - 1) AND NOT (SizeOf(pointer) - 1); + //calculate DataBuffer + FDataBuffer := HeapAlloc(GetProcessHeap, HEAP_GENERATE_EXCEPTIONS, bufferElementSize * numElements + 2 * SizeOf(TReferencedPtr) + CASAlignment); + dataBuffer := RoundUpTo(FDataBuffer, CASAlignment); + if NativeInt(dataBuffer) AND (SizeOf(pointer) - 1) <> 0 then + // TODO 1 raise exception - how? + Halt; //raise Exception.Create('TOmniBaseContainer: obcBuffer is not aligned'); + FPublicChainP := dataBuffer; + inc(NativeInt(dataBuffer), SizeOf(TReferencedPtr)); + FRecycleChainP := dataBuffer; + inc(NativeInt(dataBuffer), SizeOf(TReferencedPtr)); + //Format buffer to recycleChain, init obsRecycleChain and obsPublicChain. + //At the beginning, all elements are linked into the recycle chain. + FRecycleChainP^.PData := dataBuffer; + currElement := FRecycleChainP^.PData; + for iElement := 0 to FNumElements - 2 do begin + nextElement := PLinkedData(NativeInt(currElement) + bufferElementSize); + currElement.Next := nextElement; + currElement := nextElement; + end; + currElement.Next := nil; // terminate the chain + FPublicChainP^.PData := nil; + MeasureExecutionTimes; +end; + +function TLFStack.IsEmpty: boolean; +begin + Result := not assigned(FPublicChainP^.PData); +end; + +function TLFStack.IsFull: boolean; +begin + Result := not assigned(FRecycleChainP^.PData); +end; + +procedure TLFStack.MeasureExecutionTimes; +const + NumOfSamples = 10; +var + TimeTestField: array [0..1] of array [1..NumOfSamples] of int64; + + function GetMinAndClear(routine, count: cardinal): int64; + var + m: cardinal; + n: integer; + x: integer; + begin + Result := 0; + for m := 1 to count do begin + x:= 1; + for n:= 2 to NumOfSamples do + if TimeTestField[routine, n] < TimeTestField[routine, x] then + x := n; + Inc(Result, TimeTestField[routine, x]); + TimeTestField[routine, x] := MaxLongInt; + end; + end; + +var + oldAffinity: NativeUInt; + currElement: PLinkedData; + n : integer; + +begin + if not obsIsInitialized then begin + oldAffinity := SetThreadAffinityMask(GetCurrentThread, 1); + try + //Calculate TaskPopDelay and TaskPushDelay counter values depend on CPU speed!!!} + obsTaskPopLoops := 1; + obsTaskPushLoops := 1; + for n := 1 to NumOfSamples do begin + SwitchToThread; + //Measure RemoveLink rutine delay + TimeTestField[0, n] := GetCPUTimeStamp; + currElement := PopLink(FRecycleChainP^); + TimeTestField[0, n] := GetCPUTimeStamp - TimeTestField[0, n]; + //Measure InsertLink rutine delay + TimeTestField[1, n] := GetCPUTimeStamp; + PushLink(currElement, FRecycleChainP^); + TimeTestField[1, n] := GetCPUTimeStamp - TimeTestField[1, n]; + end; + //Calculate first 4 minimum average for RemoveLink rutine + obsTaskPopLoops := GetMinAndClear(0, 4) div 4; + //Calculate first 4 minimum average for InsertLink rutine + obsTaskPushLoops := GetMinAndClear(1, 4) div 4; + + //This gives better performance (determined experimentally) + obsTaskPopLoops := obsTaskPopLoops * 2; + obsTaskPushLoops := obsTaskPushLoops * 2; + + obsIsInitialized := true; + finally SetThreadAffinityMask(GetCurrentThread, oldAffinity); end; + end; +end; + +function TLFStack.Pop(var value): boolean; +var + linkedData: PLinkedData; +begin + linkedData := PopLink(FPublicChainP^); + Result := assigned(linkedData); + if not Result then + Exit; + Move(linkedData.Data, value, ElementSize); + PushLink(linkedData, FRecycleChainP^); +end; + +class function TLFStack.PopLink(var chain: TReferencedPtr): PLinkedData; +//nil << Link.Next << Link.Next << ... << Link.Next +// ^------ < chainHead +var + AtStartReference: NativeInt; + CurrentReference: NativeInt; + TaskCounter : NativeInt; + ThreadReference : NativeInt; +label + TryAgain; +begin + ThreadReference := GetThreadId + 1; //Reference.bit0 := 1 + with chain do begin +TryAgain: + TaskCounter := obsTaskPopLoops; + AtStartReference := Reference OR 1; //Reference.bit0 := 1 + repeat + CurrentReference := Reference; + Dec(TaskCounter); + until (TaskCounter = 0) or (CurrentReference AND 1 = 0); + if (CurrentReference AND 1 <> 0) and (AtStartReference <> CurrentReference) or + not CAS(CurrentReference, ThreadReference, Reference) + then + goto TryAgain; + //Reference is set... + Result := PData; + //Empty test + if result = nil then + CAS(ThreadReference, 0, Reference) //Clear Reference if task own reference + else if not CAS(Result, ThreadReference, Result.Next, 0, chain) then + goto TryAgain; + end; //with chain +end; + +function TLFStack.Push(const value): boolean; +var + linkedData: PLinkedData; +begin + linkedData := PopLink(FRecycleChainP^); + Result := assigned(linkedData); + if not Result then + Exit; + Move(value, linkedData.Data, ElementSize); + PushLink(linkedData, FPublicChainP^); +end; + +class procedure TLFStack.PushLink(const link: PLinkedData; var chain: TReferencedPtr); +var + PMemData : pointer; + TaskCounter: NativeInt; +begin + with chain do begin + for TaskCounter := 0 to obsTaskPushLoops do + if (Reference AND 1 = 0) then + break; + repeat + PMemData := PData; + link.Next := PMemData; + until CAS(PMemData, link, PData); + end; +end; + +procedure InitializeTimingInfo; +var + stack: TLFStack; +begin + stack.Initialize(10, 4); // enough for initialization + stack.Finalize; +end; + +initialization + {$IFDEF CPUX64} + CASAlignment := 16; + {$ELSE} + CASAlignment := 8; + {$ENDIF CPUX64} + InitializeTimingInfo; +end. diff --git a/contrib/FastMM4-AVX/FastMM4Messages.pas b/contrib/FastMM4-AVX/FastMM4Messages.pas new file mode 100644 index 0000000..8df7cf9 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4Messages.pas @@ -0,0 +1,158 @@ +{ + +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} + {$IFDEF MACOS} + FullDebugModeLibraryName32Bit = 'libFastMM_FullDebugMode.dylib'; + {$ELSE} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + {$ENDIF} + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unknown'; + {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. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: '; + CurrentBlockSizeMsg = #13#10#13#10'The block size is: '; + 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: '; + BlockErrorMsgTitle = 'Memory Error Detected'; + 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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} + +{$ifdef LogLockContention} + LockingReportTitle = 'Locking Report'; + LockingReportHeader = 'Top locking contention sites'; +{$endif} + +{$ifdef UseReleaseStack} +{$ifdef DebugReleaseStack} + ReleaseStackUsageHeader = 'Release stack usage statistics'; + ReleaseStackUsageSmallBlocksMsg1 = 'Small blocks ['; + ReleaseStackUsageSmallBlocksMsg2 = ']: '; + ReleaseStackUsageTotalSmallBlocksMsg = 'Total small blocks: '; + ReleaseStackUsageMediumBlocksMsg = 'Medium blocks: '; + ReleaseStackUsageLargeBlocksMsg = 'Large blocks: '; + ReleaseStackUsageTotalMemoryMsg = 'Total memory: '; + ReleaseStackUsageBuffers1Msg = ' in '; + ReleaseStackUsageBuffers2Msg = ' buffers ['; +{$endif} +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/FastMM4Options.inc b/contrib/FastMM4-AVX/FastMM4Options.inc new file mode 100644 index 0000000..f7b18a2 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4Options.inc @@ -0,0 +1,763 @@ +{ + +Fast Memory Manager: Options Include File + +Set the default options for FastMM here. + +} + +{---------------------------Miscellaneous Options-----------------------------} + +{Enable Align16Bytes define to align all data blocks on 16 byte boundaries, + or enable Align32Bytes define to align all blocks on 32 byte boundaries, + so aligned SSE instructions can be used safely. + + If neither of these options are enabled, then some of the + smallest block sizes will be 8-byte aligned instead which may result in a + reduction in memory usage. + + Even when small blocks are aligned by 8 bytes + (no Align16Bytes or Align32Bytes are defined), + Medium and large blocks are always 16-byte aligned. + + If you enable AVX, then the alignment will always be 32 bytes. However, if your + CPU supports "Fast Short REP MOVSB" (Ice Lake or newer), you can disable AVX, + and align by just 8 bytes, and this may even be faster because less memory is + wasted on alignment} + +{.$define Align16Bytes} +{.$define Align32Bytes} + + +{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 this option to only install FastMM as the memory manager when the + application is running inside the Delphi IDE. This is useful when you want + to deploy the same EXE that you use for testing, but only want the debugging + features active on development machines. When this option is enabled and + the application is not being run inside the IDE debugger, then the default + Delphi memory manager will be used (which, since Delphi 2006, is FastMM + without FullDebugMode.} + +{.$define InstallOnlyIfRunningInIDE} + + +{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} + + + +{-----------------------Concurrency Management Options------------------------} + +{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. Since the primary goal of FastMM4-AVX is improvement in + multi-threaded applications, this option is enabled by default. However, if you + know for sure that your application is Single-Threaded, undefine this to improve + performance - this will save yo from unnecessary locking! } + +{$define AssumeMultiThreaded} + + +{Enable to always assume that the CPU supports "pause" instruction and Windows +supports SwitchToThread() API call. This option has no effect for 64-bit target, +since it is always assumed under 64-bit that both "pause" and SwitchToThread() +are supported. So it is only relevant for 32-bit platforms with very old CPUs. +If you are sure that "pause" and SwithchToThread() are always avaialbe, the +program may skip checking and improve speed. However, if you define +"DisablePauseAndSwitchToThread", then "AssumePauseAndSwitchToThreadAvailable" +will be automatically undefined} + +{.$define AssumePauseAndSwitchToThreadAvailable} + + +{ If you disable "pause" and SwitchToThread() by defining the +DisablePauseAndSwitchToThread, then EnterCriticalSection/LeaveCriticalSection +calls will be used instead } + +{.$define DisablePauseAndSwitchToThread} + + +{Enable this option to not call Sleep when 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 usually enter a "busy waiting" loop instead of relinquishing its + timeslice when a thread contention occurs, unless UseSwitchToThread is + also defined (see below) in which case it will call SwitchToThread instead of + Sleep. + +*** Note: This option was added in FastMM 4 version Version 4.68 + on 3 July 2006, is provided only if you wish to restore old + functionality (e.g. for testing, etc.), and is not recommended + for FastMM4-AVX, since this it provides suboptimal performance compare + to the new locking mechanism implemented in the FastMM4-AVX. +This option has no effect when SmallBlocksLockedCriticalSection/ +MediumBlocksLockedCriticalSection/LargeBlocksLockedCriticalSection is enabled} + +{.$define NeverSleepOnThreadContention} + + +{Set this option to call SwitchToThread instead of sitting in a "busy waiting" + loop when a thread contention occurs. This is used in conjunction with the + NeverSleepOnThreadContention option, and has no effect unless + NeverSleepOnThreadContention is also defined. This option may improve + performance with many CPU cores and/or threads of different priorities. Note + that the SwitchToThread API call is only available on Windows 2000 and later, + but FastMM4 loads it dynamically, so it would not fail even under very old + versions of Windows. + +*** Note: This option was added in FastMM 4 version Version 4.97 + on 30 September 2010, is provided only if you wish to restore old + functionality (e.g. for testing, etc.), and is not recommended + for FastMM4-AVX, since this it provides suboptimal performance compare + to the new locking mechanism implemented in the FastMM4-AVX. +This option has no effect when SmallBlocksLockedCriticalSection/ +MediumBlocksLockedCriticalSection/LargeBlocksLockedCriticalSection is enabled} + +{.$define UseSwitchToThread} + + +{This option uses a simpler instruction to acquire a lock: "lock xchg", +instead of "lock cmpxchg" used in earlier versions of FastMM4: there is +actually no reason to use "cmpxchg", because the simple instruction - "xchg" - +perfectly suits our need. Although "xchg" has exactly the same latency and +costs in terms of CPU cycles as "cmpxghg", it is just simper way to do the +lock that we need, and, according to the Occam's razor principle, simple things +are better. If you wish to restore old functionality of FastMM4 version 4.992, +disable this option } + +{$define SimplifiedInterlockedExchangeByte} + + +{These 3 options make FastMM4-AVX use a new approach to waiting for a lock: +CriticalSections or "pause"-based spin-wait loops instead of Sleep() or +SwitchToThread(). +Using Sleep(0) or SwitchToThread() while waiting for a lock is a default +approach in the original version of FastMM. +With the new approach, the Sleep() will never be called, and SwitchToThread() +may only be called after 5000 cycles of "pause"-based spin-wait loop. +Testing has shown that the new approach provides significant gain in +multi-threaded scenarios, especially in situations when the number of threads +working with the memory manager is the same or higher than the number of +physical cores. +Critical Sections or "pause"-based spin-wait loops implemented as +"test, test-and-set" are much more CPU-friendly and have definitely lower +latency than Sleep() or SwitchToThread(). + +When these options are enabled, FastMM4-AVX checks: + - whether the CPU supports SSE2 and thus the "pause" instruction, and + - whether the operating system has the SwitchToThread() API call, and, +if both of the above conditions are met, uses +"pause"-based spin-wait loops for 5000 iterations and then +SwitchToThread() instead of critical sections; If a CPU doesn't have the +"pause" instrcution or Windows doesn't have the SwitchToThread() API +function, it will use EnterCriticalSection/LeaveCriticalSection. + +If you wound not define the 3 options below, you will get the locking +mechanism from the original FastMM4} + +{$define SmallBlocksLockedCriticalSection} +{$define MediumBlocksLockedCriticalSection} +{$define LargeBlocksLockedCriticalSection} + + + +{ Use this option if you need that releasing a lock on data structure, +i.e. writing to a synchronization variable, to use bus-locking memory store +(lock xchg) rather than just the normal memory store (mov). +Using bus-locking memory store to release a lock on data structure is +an old approach of the original FastMM4, and is not recommended +for FastMM4-AVX. Look for "using normal memory store" in the comment section +at the beginning of the main .pas file for the discussion } + +{.$define InterlockedRelease} + + +{-----------------------------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 of GetMem and FreeMem + which is faster than the pascal version. Disable only for debugging purposes. + Setting the CheckHeapForCorruption option automatically disables this option.} + +{$define ASMVersion} + + +{Set this option to disable any inline assembly at all. However, it would not +be able to use efficient locking without inline assembly.} + +{.$define PurePascal} + + +{Define the "EnableAsmCodeAlign" to allow using ".align" assembler + directive for the 32-bit or 64-bit inline assembly. + Delphi 32-bit or 64-bit compiler incorrectly encodes conditional jumps + (used 6-byte instructions instead of just 2 bytes, so it prevents branch + predicions. So for Embarcadero (former Borland) 32-bit or 64-bit + Delphi, EnableAsmCodeAlign will have no effect. However, undre FreePascal + it turns on using the ".align". To force using it under Delphi, define + "ForceAsmCodeAlign" } + + +{$define EnableAsmCodeAlign} +{.$define ForceAsmCodeAlign} + + +{Allow pascal code alignment} + +{$define PasCodeAlign} + + +{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 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} + + + {.$define DoNotInstallIfDLLMissing} + {If the FastMM_FullDebugMode.dll file is not available then FastMM will not + install itself. No effect unless FullDebugMode and LoadDebugDLLDynamically + are also defined.} + + {.$define RestrictDebugDLLLoadPath} + {Allow to load debug dll only from host module directory.} + + + {FastMM usually allocates large blocks from the topmost available address and + medium and small blocks from the lowest available address (This reduces + fragmentation somewhat). With this option set all blocks are always + allocated from the highest available address. If the process has a >2GB + address space and contains bad pointer arithmetic code, this option should + help to catch those errors sooner.} + + {$define AlwaysAllocateTopDown} + + + {Disables the logging of memory dumps together with the other detail for + memory errors.} + + {.$define DisableLoggingOfMemoryDumps} + + + {If FastMM encounters a problem with a memory block inside the FullDebugMode + FreeMem handler then an "invalid pointer operation" exception will usually + be raised. If the FreeMem occurs while another exception is being handled + (perhaps in the try.. finally code) then the original exception will be + lost. With this option set FastMM will ignore errors inside FreeMem when an + exception is being handled, thus allowing the original exception to + propagate.} + + {$define SuppressFreeMemErrorsInsideException} + + + {Adds support for notification of memory manager events in FullDebugMode. + With this define set, the application may assign the OnDebugGetMemFinish, + OnDebugFreeMemStart, etc. callbacks in order to be notified when the + particular memory manager event occurs.} + + {.$define FullDebugModeCallBacks} + + + +{---------------------------Memory Leak Reporting-----------------------------} + +{Set the option EnableMemoryLeakReporting to enable reporting of memory leaks. +Combine it with the two options below for further fine-tuning.} + +{$ifndef DisableMemoryLeakReporting} +{$define EnableMemoryLeakReporting} +{$endif} + + + {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. Note that this option does not + work with libraries, only EXE projects.} + + {$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} + + + {Set this option to use QualifiedClassName equivalent instead of ClassName + equivalent during memory leak reporting. + This is useful for duplicate class names (like EConversionError, which is in + units Data.DBXJSONReflect, REST.JsonReflect and System.ConvUtils, + or TClipboard being in Vcl.Clibprd and WinAPI.ApplicationModel.DataTransfer } + + {$define EnableMemoryLeakReportingUsesQualifiedClassName} + + +{--------------------------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} + + +{$ifndef DontForceMMX} + + {Set this option (ForceMMX) 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} + +{$endif} + + +{$ifndef DisableAVX} + + {Set this option (EnableAVX) to enable use of AVX instructions under 64-bit mode. + This option has no effect under 32-bit mode. If enabled, the code will check + whether the CPU supports AVX or AVX2, and, if yes, will use the 32-byte YMM + registers for faster memory copy. Besides that, if this option is enabled, + all allocated memory blocks will be aligned by 32 bytes, that will incur + addition memory consumption overhead. Besides that, with this option, memory + copy will be slightly more secure, because all XMM/YMM registers used to copy + memory will be cleared by vxorps/vpxor at the end of a copy routine, so the + leftovers of the copied memory data will not be kept in the XMM/YMM registers + and will not be exposed. This option properly handles AVX-SSE transitions to not + incur the transition penalties, only calls vzeroupper under AVX1, but not under + AVX2, since it slows down subsequent SSE code under Kaby Lake} + + {$define EnableAVX} + +{$endif} + + +{$ifdef EnableAVX} + {If AVX is enabled, you can optionally disable one or more + of the following AVX modes: + - the first version - initial AVX (DisableAVX1); or + - the second version AVX2 (DisableAVX2); or + - AVX-512 (DisableAVX512); + but you cannot disable all of the above modes at once. + + If you define DisableAVX1, it will not add to FastMM4 the instructions from + the initial (first) version of the Advanced Vector Extensions instruction set, + officially called just "AVX", proposed by Intel in March 2008 and first + supported by Intel with the Sandy Bridge processor shipping in Q1 2011 + and later, on by AMD with the Bulldozer processor shipping in Q3 2011. + + If you define DisableAVX2, it will not add to FastMM4 the instructions from + the second version of the Advanced Vector Extensions - officially called + "AVX2", also known as Haswell New Instructions, which is an expansion of the + AVX instruction set introduced in Intel's Haswell microarchitecture. + Intel has shipped first processors with AVX2 on June 2, 2013: Core i7 4770, + Core i5 4670, etc., and AMD has shipped first processors with AVX in Q2 2015 + (Carrizo processor). AMD Ryzen processor (Q1 2017) also supports AVX2. + We use separate code for AVX1 and AVX2 because AVX2 doesn't use "vzeroupper" + and uses the new, faster instruction "vpxor" which was not available in the + initial AVX, which, in its turn, uses "vxorps" and "vzeroupper" before and + after any AVX code to counteract the AVX-SSE transition penalties. + FastMM4 checks whether AVX2 is supported by the CPU, and, if supported, never + calls AVX1 functions, since calling "vzeroupper" even once in a thread + significantly slows down all subsequent SSE code, which is not documented: + neither in the Intel 64 and IA-32 Architectures Software Developers Manual + nor in the Intel 64 and IA-32 Architectures Optimization Reference Manual. + + The code of AVX1 is grouped separately from the code of AVX2, to not scatter + the cache} + + + {.$define DisableAVX1} + {.$define DisableAVX2} + {$define DisableAVX512} +{$endif} + + +{$ifndef DisableERMS} + + {Set this option (EnableERMS) to enable Enhanced Rep Movsb/Stosb CPU feature, + which improves speed of medium and large block memory copy + under 32-bit or 64-bit modes after checking the corresponding CPUID bit} + + {$define EnableERMS} + +{$endif} + + +{$ifndef DisableFSRM} + + {Set this option (EnableFSRM) to enable Fast Short REP MOVSB CPU feature, + introduced by the Ice Lake microarchitecture, which improves speed of small + block memory copy under 64-bit mode after checking the corresponding CPUID bit} + + {$define EnableFSRM} + +{$endif} + +{-----------------------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 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} + + +{Define this to enable backward compatibility for the memory manager sharing + mechanism used by Delphi 2006 and 2007, as well as older FastMM versions.} + + {$define EnableBackwardCompatibleMMSharing} + + + +{-----------------------Security Options------------------------} + +{Windows clears physical memory before reusing it in another process. However, + it is not known how quickly this clearing is performed, so it is conceivable + that confidential data may linger in physical memory longer than absolutely + necessary. If you're paranoid about this kind of thing, enable this option to + clear all freed memory before returning it to the operating system. Note that + this incurs a noticeable performance hit.} + +{.$define ClearMemoryBeforeReturningToOS} + + +{With this option enabled freed memory will immediately be cleared inside the + FreeMem routine. This incurs a big performance hit, but may be worthwhile for + additional peace of mind when working with highly sensitive data. This option + supersedes the ClearMemoryBeforeReturningToOS option.} + +{.$define AlwaysClearFreedMemory} + + + +{----------------------------Lock Contention Logging--------------------------} + +{Define this to lock stack traces for all occasions where GetMem/FreeMem + go to sleep because of lock contention (IOW, when memory manager is already + locked by another thread). At the end of the program execution top 10 sites + (locations with highest occurrence) will be logged to the _MemoryManager_EventLog.txt + file. + This options works with FullDebugMode or without it, but requires + FastMM_FullDebugMode.dll to be present in both cases.} + +{.$define LogLockContention} + + + +{--------------------------------Option Grouping------------------------------} + +{Enabling this option enables FullDebugMode, InstallOnlyIfRunningInIDE and + LoadDebugDLLDynamically. Consequently, FastMM will install itself in + FullDebugMode if the application is being debugged inside the Delphi IDE. + Otherwise the default Delphi memory manager will be used (which is equivalent + to the non-FullDebugMode FastMM since Delphi 2006.)} + +{.$define FullDebugModeInIDE} + + +{Combines the FullDebugMode, LoadDebugDLLDynamically and + DoNotInstallIfDLLMissing options. Consequently FastMM will only be installed + (In FullDebugMode) when the FastMM_FullDebugMode.dll file is available. This + is useful when the same executable will be distributed for both debugging as + well as deployment.} + +{.$define FullDebugModeWhenDLLAvailable} + + +{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} + +{Move BCB related definitions here, because CB2006/CB2007 can build borlndmm.dll + for tracing memory leaks in BCB applications with "Build with Dynamic RTL" + switched on} +{------------------------------Patch BCB Terminate----------------------------} +{To enable the patching for BCB to make uninstallation and leak reporting + possible, you may need to add "BCB" definition + in "Project Options->Pascal/Delphi Compiler->Defines". + (Thanks to JiYuan Xie for implementing this.)} + +{$ifdef BCB} + {$ifdef CheckHeapForCorruption} + {$define PatchBCBTerminate} + {$else} + {$ifdef DetectMMOperationsAfterUninstall} + {$define PatchBCBTerminate} + {$else} + {$ifdef EnableMemoryLeakReporting} + {$define PatchBCBTerminate} + {$endif} + {$endif} + {$endif} + + {$ifdef PatchBCBTerminate} + {$define CheckCppObjectType} + {$undef CheckCppObjectTypeEnabled} + + {$ifdef CheckCppObjectType} + {$define CheckCppObjectTypeEnabled} + {$endif} + + {Turn off "CheckCppObjectTypeEnabled" option if neither "CheckHeapForCorruption" + option or "EnableMemoryLeakReporting" option were defined.} + {$ifdef CheckHeapForCorruption} + {$else} + {$ifdef EnableMemoryLeakReporting} + {$else} + {$undef CheckCppObjectTypeEnabled} + {$endif} + {$endif} + {$endif} +{$endif} diff --git a/contrib/FastMM4-AVX/FastMM4_AVX512.asm b/contrib/FastMM4-AVX/FastMM4_AVX512.asm new file mode 100644 index 0000000..abb626c --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4_AVX512.asm @@ -0,0 +1,343 @@ +; This file is needed to enable AVX-512 code for FastMM4-AVX. +; Use "nasm.exe -Ox -f win64 FastMM4_AVX512.asm" to compile this file +; You can get The Netwide Assembler (NASM) from http://www.nasm.us/ + +; This file is a part of FastMM4-AVX. +; - Copyright (C) 2017-2020 Ritlabs, SRL. All rights reserved. +; - Copyright (C) 2020-2021 Maxim Masiutin. All rights reserved. +; Written by Maxim Masiutin + +; FastMM4-AVX is a fork of the Fast Memory Manager 4.992 by Pierre le Riche + +; FastMM4-AVX is released under a dual license, and you may choose to use it +; under either the Mozilla Public License 2.0 (MPL 2.1, available from +; https://www.mozilla.org/en-US/MPL/2.0/) or the GNU Lesser General Public +; License Version 3, dated 29 June 2007 (LGPL 3, available from +; https://www.gnu.org/licenses/lgpl.html). + +; This code uses zmm26 - zmm31 registers to avoid AVX-SSE transition penalty. +; These regsters (zmm16 - zmm31) have no non-VEX counterpart. According to the +; advise of Agner Fog, there is no state transition and no penalty for mixing +; zmm16 - zmm31 with non-VEX SSE code. By using these registers (zmm16 - zmm31) +; rather than zmm0-xmm15 we save us from calling "vzeroupper". +; Source: +; https://stackoverflow.com/questions/43879935/avoiding-avx-sse-vex-transition-penalties/54587480#54587480 + + +%define EVEXR512N0 zmm31 +%define EVEXR512N1 zmm30 +%define EVEXR512N2 zmm29 +%define EVEXR512N3 zmm28 +%define EVEXR512N4 zmm27 +%define EVEXR512N5 zmm26 +%define EVEXR256N0 ymm31 +%define EVEXR256N1 ymm30 +%define EVEXR256N2 ymm29 +%define EVEXR256N3 ymm28 +%define EVEXR256N4 ymm27 +%define EVEXR256N5 ymm26 +%define EVEXR128N0 xmm31 +%define EVEXR128N1 xmm30 +%define EVEXR128N2 xmm29 +%define EVEXR128N3 xmm28 +%define EVEXR128N4 xmm27 +%define EVEXR128N5 xmm26 + + +section .text + + global Move24AVX512 + global Move56AVX512 + global Move88AVX512 + global Move120AVX512 + global Move152AVX512 + global Move184AVX512 + global Move216AVX512 + global Move248AVX512 + global Move280AVX512 + global Move312AVX512 + global Move344AVX512 + global MoveX32LpAvx512WithErms + + %use smartalign + ALIGNMODE p6, 32 ; p6 NOP strategy, and jump over the NOPs only if they're 32B or larger. + + align 16 +Move24AVX512: + vmovdqa64 EVEXR128N0, [rcx] + mov r8, [rcx+10h] + vmovdqa64 [rdx], EVEXR128N0 + mov [rdx+10h], r8 + vpxord EVEXR128N0, EVEXR128N0, EVEXR128N0 + ret + +Move56AVX512: + vmovdqa64 EVEXR256N0, [rcx+00h] + vmovdqa64 EVEXR128N1, [rcx+20h] + mov r8, [rcx+30h] + vmovdqa64 [rdx+00h], EVEXR256N0 + vmovdqa64 [rdx+20h], EVEXR128N1 + mov [rdx + 48], r8 + vpxord EVEXR256N0, EVEXR256N0, EVEXR256N0 + vpxord EVEXR128N1, EVEXR128N1, EVEXR128N1 + ret + + align 16 +Move88AVX512: + vmovdqu64 EVEXR512N0, [rcx] + vmovdqa64 EVEXR128N1, [rcx+40h] + mov rcx, [rcx+50h] + vmovdqu64 [rdx], EVEXR512N0 + vmovdqa64 [rdx+40h], EVEXR128N1 + mov [rdx+50h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR128N1,EVEXR128N1,EVEXR128N1 + ret + + align 16 +Move120AVX512: + vmovdqu64 EVEXR512N0, [rcx] + vmovdqa64 EVEXR256N1, [rcx+40h] + vmovdqa64 EVEXR128N2, [rcx+60h] + mov rcx, [rcx + 70h] + vmovdqu64 [rdx], EVEXR512N0 + vmovdqa64 [rdx+40h], EVEXR256N1 + vmovdqa64 [rdx+60h], EVEXR128N2 + mov [rdx+70h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR256N1,EVEXR256N1,EVEXR256N1 + vpxord EVEXR128N2,EVEXR128N2,EVEXR128N2 + ret + + align 16 +Move152AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqa64 EVEXR128N2, [rcx+80h] + mov rcx, [rcx+90h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqa64 [rdx+80h], EVEXR128N2 + mov [rdx+90h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR128N2,EVEXR128N2,EVEXR128N2 + ret + + align 16 +Move184AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqa64 EVEXR256N2, [rcx+80h] + vmovdqa64 EVEXR128N3, [rcx+0A0h] + mov rcx, [rcx+0B0h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqa64 [rdx+80h], EVEXR256N2 + vmovdqa64 [rdx+0A0h],EVEXR128N3 + mov [rdx+0B0h],rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR256N2,EVEXR256N2,EVEXR256N2 + vpxord EVEXR128N3,EVEXR128N3,EVEXR128N3 + ret + + align 16 +Move216AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqu64 EVEXR512N2, [rcx+80h] + vmovdqa64 EVEXR128N3, [rcx+0C0h] + mov rcx, [rcx+0D0h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqu64 [rdx+80h], EVEXR512N2 + vmovdqa64 [rdx+0C0h], EVEXR128N3 + mov [rdx+0D0h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR512N2,EVEXR512N2,EVEXR512N2 + vpxord EVEXR128N3,EVEXR128N3,EVEXR128N3 + ret + + align 16 +Move248AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqu64 EVEXR512N2, [rcx+80h] + vmovdqa64 EVEXR256N3, [rcx+0C0h] + vmovdqa64 EVEXR128N4, [rcx+0E0h] + mov rcx, [rcx+0F0h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqu64 [rdx+80h], EVEXR512N2 + vmovdqa64 [rdx+0C0h], EVEXR256N3 + vmovdqa64 [rdx+0E0h], EVEXR128N4 + mov [rdx+0F0h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR512N2,EVEXR512N2,EVEXR512N2 + vpxord EVEXR256N3,EVEXR256N3,EVEXR256N3 + vpxord EVEXR128N4,EVEXR128N4,EVEXR128N4 + ret + + align 16 +Move280AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqu64 EVEXR512N2, [rcx+80h] + vmovdqu64 EVEXR512N3, [rcx+0C0h] + vmovdqa64 EVEXR128N4, [rcx+100h] + mov rcx, [rcx+110h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqu64 [rdx+80h], EVEXR512N2 + vmovdqu64 [rdx+0C0h], EVEXR512N3 + vmovdqa64 [rdx+100h], EVEXR128N4 + mov [rdx+110h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR512N2,EVEXR512N2,EVEXR512N2 + vpxord EVEXR512N3,EVEXR512N3,EVEXR512N3 + vpxord EVEXR128N4,EVEXR128N4,EVEXR128N4 + ret + + align 16 +Move312AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqu64 EVEXR512N2, [rcx+80h] + vmovdqu64 EVEXR512N3, [rcx+0C0h] + vmovdqa64 EVEXR256N4, [rcx+100h] + vmovdqa64 EVEXR128N5, [rcx+120h] + mov rcx, [rcx+130h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqu64 [rdx+80h], EVEXR512N2 + vmovdqu64 [rdx+0C0h], EVEXR512N3 + vmovdqa64 [rdx+100h], EVEXR256N4 + vmovdqa64 [rdx+120h], EVEXR128N5 + mov [rdx+130h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR512N2,EVEXR512N2,EVEXR512N2 + vpxord EVEXR512N3,EVEXR512N3,EVEXR512N3 + vpxord EVEXR256N4,EVEXR256N4,EVEXR256N4 + vpxord EVEXR128N5,EVEXR128N5,EVEXR128N5 + ret + + align 16 +Move344AVX512: + vmovdqu64 EVEXR512N0, [rcx+00h] + vmovdqu64 EVEXR512N1, [rcx+40h] + vmovdqu64 EVEXR512N2, [rcx+80h] + vmovdqu64 EVEXR512N3, [rcx+0C0h] + vmovdqu64 EVEXR512N4, [rcx+100h] + vmovdqa64 EVEXR128N5, [rcx+140h] + mov rcx, [rcx+150h] + vmovdqu64 [rdx+00h], EVEXR512N0 + vmovdqu64 [rdx+40h], EVEXR512N1 + vmovdqu64 [rdx+80h], EVEXR512N2 + vmovdqu64 [rdx+0C0h], EVEXR512N3 + vmovdqu64 [rdx+100h], EVEXR512N4 + vmovdqa64 [rdx+140h], EVEXR128N5 + mov [rdx+150h], rcx + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + vpxord EVEXR512N2,EVEXR512N2,EVEXR512N2 + vpxord EVEXR512N3,EVEXR512N3,EVEXR512N3 + vpxord EVEXR512N4,EVEXR512N4,EVEXR512N4 + vpxord EVEXR128N5,EVEXR128N5,EVEXR128N5 + ret + + + align 16 +MoveX32LpAvx512WithErms: + +; Make the counter negative based: The last 24 bytes are moved separately + + mov eax, 8 + sub r8, rax + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast8 + + cmp r8, -2048 ; According to the Intel Manual, rep movsb outperforms AVX copy on blocks of 2048 bytes and above + jg @DontDoRepMovsb + + align 4 + +@DoRepMovsb: + mov r10, rsi + mov r9, rdi + lea rsi, [rcx+r8] + lea rdi, [rdx+r8] + neg r8 + add r8, rax + mov rcx, r8 + cld + rep movsb + mov rdi, r9 + mov rsi, r10 + jmp @exit + + align 16 + +@DontDoRepMovsb: + cmp r8, -(128+64) + jg @SmallAvxMove + + mov eax, 128 + + sub rcx, rax + sub rdx, rax + add r8, rax + + + lea r9, [rdx+r8] + test r9b, 63 + jz @Avx512BigMoveDestAligned + +; destination is already 32-bytes aligned, so we just align by 64 bytes + vmovdqa64 EVEXR256N0, [rcx+r8] + vmovdqa64 [rdx+r8], EVEXR256N0 + add r8, 20h + + align 16 + +@Avx512BigMoveDestAligned: + vmovdqu64 EVEXR512N0, [rcx+r8+00h] + vmovdqu64 EVEXR512N1, [rcx+r8+40h] + vmovdqa64 [rdx+r8+00h], EVEXR512N0 + vmovdqa64 [rdx+r8+40h], EVEXR512N1 + add r8, rax + js @Avx512BigMoveDestAligned + + sub r8, rax + add rcx, rax + add rdx, rax + + align 16 + +@SmallAvxMove: + +@MoveLoopAvx: +; Move a 16 byte block + vmovdqa64 EVEXR128N0, [rcx+r8] + vmovdqa64 [rdx+r8], EVEXR128N0 + +; Are there another 16 bytes to move? + add r8, 16 + js @MoveLoopAvx + + vpxord EVEXR512N0,EVEXR512N0,EVEXR512N0 + vpxord EVEXR512N1,EVEXR512N1,EVEXR512N1 + + align 8 +@MoveLast8: +; Do the last 8 bytes + mov rcx, [rcx+r8] + mov [rdx+r8], rcx +@exit: + ret diff --git a/contrib/FastMM4-AVX/FastMM4_FAQ.txt b/contrib/FastMM4-AVX/FastMM4_FAQ.txt new file mode 100644 index 0000000..68b25c6 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4_FAQ.txt @@ -0,0 +1,74 @@ +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. You may use FullDebugMode to shed more light on the cause of the problem. + +Q: When I enable the FullDebugMode option my application crashes 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: When a memory error pops up in "FullDebugMode" there is no debug info in the stack traces, only addresses. 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". 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: 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 "FullDebugMode" 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 memory manager of Delphi 2005 (and older Delphi versions), 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: 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/contrib/FastMM4-AVX/FastMM4_Readme.txt b/contrib/FastMM4-AVX/FastMM4_Readme.txt new file mode 100644 index 0000000..54aabc6 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM4_Readme.txt @@ -0,0 +1,125 @@ +Fast Memory Manager - Readme +---------------------------- + +Description: +------------ + +A fast replacement memory manager for Embarcadero Delphi Win32 applications that scales well under multi-threaded usage, is not prone to memory fragmentation, and supports shared memory without the use of external .DLL files. + + + +Homepage: +--------- + +https://github.com/pleriche/FastMM4 + + + +Usage: +------ + +Delphi: Place this unit as the very first unit under the "uses" section in your project's .dpr file. When sharing memory between an application and a DLL (e.g. when passing a long string or dynamic array to a DLL function), both the main application and the DLL must be compiled using this memory manager (with the required conditional defines set). There are some conditional defines (inside FastMM4Options.inc) that may be used to tweak the memory manager. To enable support for a user mode address space greater than 2GB you will have to use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header. This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the application supports an address space larger than 2GB (up to 4GB). In Delphi 6 and later you can also specify this flag through the compiler directive {$SetPEFlags $20} +*The EditBin tool ships with the MS Visual C compiler. +C++ Builder 6: Refer to the instructions inside FastMM4BCB.cpp. + + + +License: +-------- + +This work is copyright Professional Software Development / Pierre le Riche. It is released under a dual license, and you may choose to use it under either the Mozilla Public License 1.1 (MPL 1.1, available from http://www.mozilla.org/MPL/MPL-1.1.html) or the GNU Lesser General Public License 2.1 (LGPL 2.1, available from http://www.opensource.org/licenses/lgpl-license.php). If you find FastMM useful or you would like to support further development, a donation would be much appreciated. My banking details are: + Country: South Africa + Bank: ABSA Bank Ltd + Branch: Somerset West + Branch Code: 334-712 + Account Name: PSD (Distribution) + Account No.: 4041827693 + Swift Code: ABSAZAJJ +My PayPal account is: + bof@psd.co.za + + + +Contact Details: +---------------- + +My contact details are shown below if you would like to get in touch with me. If you use this memory manager I would like to hear from you: please e-mail me your comments - good and bad. + +Snailmail: + PO Box 2514 + Somerset West + 7129 + South Africa + +E-mail: + plr@psd.co.za + + + +Support: +-------- + +If you have trouble using FastMM, you are welcome to drop me an e-mail at the address above, or you may post your questions in the BASM newsgroup on the Embarcadero news server (which is where I hang out quite frequently). + + + +Disclaimer: +----------- + +FastMM has been tested extensively with both single and multithreaded applications on various hardware platforms, but unfortunately I am not in a position to make any guarantees. Use it at your own risk. + + + +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.embarcadero.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/contrib/FastMM4-AVX/FastMM_OSXUtil.pas b/contrib/FastMM4-AVX/FastMM_OSXUtil.pas new file mode 100644 index 0000000..d41cdd7 --- /dev/null +++ b/contrib/FastMM4-AVX/FastMM_OSXUtil.pas @@ -0,0 +1,328 @@ +unit FastMM_OSXUtil; + +interface + +type + LPCSTR = PAnsiChar; + LPSTR = PAnsiChar; + DWORD = Cardinal; + BOOL = Boolean; + + PSystemTime = ^TSystemTime; + _SYSTEMTIME = record + wYear: Word; + wMonth: Word; + wDayOfWeek: Word; + wDay: Word; + wHour: Word; + wMinute: Word; + wSecond: Word; + wMilliseconds: Word; + end; + TSystemTime = _SYSTEMTIME; + SYSTEMTIME = _SYSTEMTIME; + SIZE_T = NativeUInt; + PUINT_PTR = ^UIntPtr; + +const + PAGE_NOACCESS = 1; + PAGE_READONLY = 2; + PAGE_READWRITE = 4; + PAGE_WRITECOPY = 8; + PAGE_EXECUTE = $10; + PAGE_EXECUTE_READ = $20; + PAGE_EXECUTE_READWRITE = $40; + PAGE_GUARD = $100; + PAGE_NOCACHE = $200; + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + MEM_FREE = $10000; + MEM_PRIVATE = $20000; + MEM_MAPPED = $40000; + MEM_RESET = $80000; + MEM_TOP_DOWN = $100000; + + EXCEPTION_ACCESS_VIOLATION = DWORD($C0000005); + + +//function GetModuleHandleA(lpModuleName: LPCSTR): HMODULE; stdcall; +function GetEnvironmentVariableA(lpName: LPCSTR; lpBuffer: LPSTR; nSize: DWORD): DWORD; stdcall; overload; +function DeleteFileA(lpFileName: LPCSTR): BOOL; stdcall; +function VirtualAlloc(lpvAddress: Pointer; dwSize: SIZE_T; flAllocationType, flProtect: DWORD): Pointer; stdcall; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall; + +procedure RaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWORD; + lpArguments: PUINT_PTR); stdcall; + +type + PSecurityAttributes = ^TSecurityAttributes; + _SECURITY_ATTRIBUTES = record + nLength: DWORD; + lpSecurityDescriptor: Pointer; + bInheritHandle: BOOL; + end; + TSecurityAttributes = _SECURITY_ATTRIBUTES; + SECURITY_ATTRIBUTES = _SECURITY_ATTRIBUTES; + +const + GENERIC_READ = DWORD($80000000); + GENERIC_WRITE = $40000000; + OPEN_ALWAYS = 4; + FILE_ATTRIBUTE_NORMAL = $00000080; + FILE_BEGIN = 0; + FILE_CURRENT = 1; + FILE_END = 2; + INVALID_SET_FILE_POINTER = DWORD(-1); + +procedure GetLocalTime(var lpSystemTime: TSystemTime); stdcall; + +function CreateFileA(lpFileName: LPCSTR; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; stdcall; + +function SetFilePointer(hFile: THandle; lDistanceToMove: Longint; + lpDistanceToMoveHigh: PLongInt; dwMoveMethod: DWORD): DWORD; stdcall; + +function CloseHandle(hObject: THandle): BOOL; stdcall; + +implementation + +uses + Posix.Stdlib, Posix.Unistd, Posix.SysMman, Posix.Fcntl, Posix.SysStat, Posix.SysTime, Posix.Time, Posix.Errno, Posix.Signal; + +function CreateFileA(lpFileName: LPCSTR; dwDesiredAccess, dwShareMode: DWORD; + lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; + hTemplateFile: THandle): THandle; stdcall; +var + Flags: Integer; + FileAccessRights: Integer; +begin +// O_RDONLY open for reading only +// O_WRONLY open for writing only +// O_RDWR open for reading and writing +// O_NONBLOCK do not block on open or for data to become available +// O_APPEND append on each write +// O_CREAT create file if it does not exist +// O_TRUNC truncate size to 0 +// O_EXCL error if O_CREAT and the file exists +// O_SHLOCK atomically obtain a shared lock +// O_EXLOCK atomically obtain an exclusive lock +// O_NOFOLLOW do not follow symlinks +// O_SYMLINK allow open of symlinks +// O_EVTONLY descriptor requested for event notifications only +// O_CLOEXEC mark as close-on-exec + + Flags := 0; + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + + case dwDesiredAccess and (GENERIC_READ or GENERIC_WRITE) of //= (GENERIC_READ or GENERIC_WRITE) then + GENERIC_READ or GENERIC_WRITE: Flags := Flags or O_RDWR; + GENERIC_READ: Flags := Flags or O_RDONLY; + GENERIC_WRITE: Flags := Flags or O_WRONLY; + else + Exit(THandle(-1)); + end; + + case dwCreationDisposition of +// CREATE_NEW: +// CREATE_ALWAYS: +// OPEN_EXISTING: + OPEN_ALWAYS: Flags := Flags or O_CREAT; +// TRUNCATE_EXISTING: + end; + + Result := THandle(__open(lpFileName, Flags, FileAccessRights)); + + // ShareMode + +// smode := Mode and $F0 shr 4; +// if ShareMode[smode] <> 0 then +// begin +// LockVar.l_whence := SEEK_SET; +// LockVar.l_start := 0; +// LockVar.l_len := 0; +// LockVar.l_type := ShareMode[smode]; +// Tvar := fcntl(FileHandle, F_SETLK, LockVar); +// Code := errno; +// if (Tvar = -1) and (Code <> EINVAL) and (Code <> ENOTSUP) then +// EINVAL/ENOTSUP - file doesn't support locking +// begin +// __close(FileHandle); +// Exit; +// end; +end; + +type + _LARGE_INTEGER = record + case Integer of + 0: ( + LowPart: DWORD; + HighPart: Longint); + 1: ( + QuadPart: Int64); + end; + + +function SetFilePointer(hFile: THandle; lDistanceToMove: Longint; + lpDistanceToMoveHigh: PLongInt; dwMoveMethod: DWORD): DWORD; stdcall; +var + dist: _LARGE_INTEGER; +begin + dist.LowPart := lDistanceToMove; + if Assigned(lpDistanceToMoveHigh) then + dist.HighPart := lpDistanceToMoveHigh^ + else + dist.HighPart := 0; + + dist.QuadPart := lseek(hFile, dist.QuadPart, dwMoveMethod); // dwMoveMethod = same as in windows + if dist.QuadPart = -1 then + Result := DWORD(-1) + else + begin + Result := dist.LowPart; + if Assigned(lpDistanceToMoveHigh) then + lpDistanceToMoveHigh^ := dist.HighPart; + end; +end; + +procedure GetLocalTime(var lpSystemTime: TSystemTime); stdcall; +var + T: time_t; + TV: timeval; + UT: tm; +begin + gettimeofday(TV, nil); + T := TV.tv_sec; + localtime_r(T, UT); + + lpSystemTime.wYear := UT.tm_year; + lpSystemTime.wMonth := UT.tm_mon; + lpSystemTime.wDayOfWeek := UT.tm_wday; + lpSystemTime.wDay := UT.tm_mday; + lpSystemTime.wHour := UT.tm_hour; + lpSystemTime.wMinute := UT.tm_min; + lpSystemTime.wSecond := UT.tm_sec; + lpSystemTime.wMilliseconds := 0; +end; + +function CloseHandle(hObject: THandle): BOOL; stdcall; +begin + Result := __close(hObject) = 0; +end; + +function StrLen(const Str: PAnsiChar): Cardinal; +begin + Result := Length(Str); +end; + +function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar; +var + Len: Cardinal; +begin + Result := Dest; + Len := StrLen(Source); + if Len > MaxLen then + Len := MaxLen; + Move(Source^, Dest^, Len * SizeOf(AnsiChar)); + Dest[Len] := #0; +end; + +function StrPLCopy(Dest: PAnsiChar; const Source: AnsiString; MaxLen: Cardinal): PAnsiChar; +begin + Result := StrLCopy(Dest, PAnsiChar(Source), MaxLen); +end; + +function GetModuleHandle(lpModuleName: PWideChar): HMODULE; +begin + Result := 0; + if lpModuleName = 'kernel32' then + Result := 1; +end; + +function GetModuleHandleA(lpModuleName: LPCSTR): HMODULE; stdcall; +begin + Result := GetModuleHandle(PChar(string(lpModuleName))); +end; + +function GetEnvironmentVariableA(lpName: LPCSTR; lpBuffer: LPSTR; nSize: DWORD): DWORD; stdcall; overload; +var + Len: Integer; + Env: string; +begin + env := string(getenv(lpName)); + + Len := Length(env); + Result := Len; + if nSize < Result then + Result := nSize; + + StrPLCopy(lpBuffer, env, Result); + if Len > nSize then + SetLastError(122) //ERROR_INSUFFICIENT_BUFFER) + else + SetLastError(0); +end; + +function DeleteFileA(lpFileName: LPCSTR): BOOL; stdcall; +begin + Result := unlink(lpFileName) <> -1; +end; + +// ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS); + + +function VirtualAlloc(lpvAddress: Pointer; dwSize: SIZE_T; flAllocationType, flProtect: DWORD): Pointer; stdcall; +var + PageSize: LongInt; + AllocSize: LongInt; + Protect: Integer; +begin + if lpvAddress <> nil then + begin + if flAllocationType <> MEM_RESERVE then + Exit(0); + + if flProtect <> PAGE_NOACCESS then + Exit(0); + + PageSize := sysconf(_SC_PAGESIZE); + AllocSize := dwSize - (dwSize mod PageSize) + PageSize; + + Result := mmap(lpvAddress, AllocSize, PROT_NONE, MAP_PRIVATE or MAP_ANON, -1, 0); + Exit; + end; + + Result := malloc(dwSize); + FillChar(Result^, dwSize, 0); + //Result := valloc(dwSize); + + + +// FreeItem.Addr := mmap(nil, PageSize, PROT_WRITE or PROT_EXEC, +// MAP_PRIVATE or MAP_ANON, -1, 0); +end; + +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: Cardinal): LongBool; stdcall; +begin + Result := True; + if dwFreetype = MEM_RELEASE then + begin + if lpAddress = Pointer($80800000) then + munmap(lpAddress, dwSize) + else + free(lpAddress); + end; +end; + +procedure RaiseException(dwExceptionCode, dwExceptionFlags, nNumberOfArguments: DWORD; + lpArguments: PUINT_PTR); stdcall; +begin + WriteLN('ACCESS VIOLATION (set breakpoint in FastMM_OSXUtil: RaiseException for easier debugging)'); + kill(getppid, SIGSEGV); + asm int 3; end; +end; + + +end. diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/CPP Builder Support/Readme.txt b/contrib/FastMM4-AVX/FullDebugMode DLL/CPP Builder Support/Readme.txt new file mode 100644 index 0000000..24239d4 --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/CPP Builder Support/Readme.txt @@ -0,0 +1,3 @@ +C++ Builder projects can statically link to FastMM_FullDebugMode.dll. For that FastMM_FullDebugMode.lib is needed. + +- JiYuan Xie \ No newline at end of file diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.deployproj b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.deployproj new file mode 100644 index 0000000..0ecf50a --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.deployproj @@ -0,0 +1,43 @@ + + + + 12 + + + + + + + FastMM_FullDebugMode\ + libFastMM_FullDebugMode.dylib.rsm + 1 + + + + + FastMM_FullDebugMode\ + libcgunwind.1.0.dylib + 1 + + + + + FastMM_FullDebugMode\ + libFastMM_FullDebugMode.dylib + 1 + + + True + + + + + + FastMM_FullDebugMode.app\ + libcgunwind.1.0.dylib + 0 + + + + + diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dpr b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dpr new file mode 100644 index 0000000..ffc3410 --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dpr @@ -0,0 +1,748 @@ +{ + +Fast Memory Manager: FullDebugMode Support DLL 1.62 + +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.) + Version 1.50 (14 August 2008): + - Added support for Delphi 2009. (Thanks to Mark Edington.) + Version 1.60 (5 May 2009): + - Improved the code used to identify call instructions in the stack trace + code. (Thanks to the JCL team.) + Version 1.61 (5 September 2010): + - Recompiled using the latest JCL in order to fix a possible crash on shutdown + when the executable contains no debug information. (Thanks to Hanspeter + Widmer.) + Version 1.62 (19 July 2012): + - Added a workaround for QC 107209 (Thanks to David Heffernan.) + Version 1.63 (14 September 2013): + - Added support for OSX (Thanks to Sebastian Zierer) + +} + +{$IFDEF MSWINDOWS} +{--------------------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-------------------------} +{$ENDIF} + +// JCL_DEBUG_EXPERT_INSERTJDBG OFF +library FastMM_FullDebugMode; + +uses + {$ifdef JCLDebug}JCLDebug,{$endif} + {$ifdef madExcept}madStackTrace,{$endif} + {$ifdef EurekaLog}ExceptionLog,{$endif} + SysUtils, {$IFDEF MACOS}Posix.Base, SBMapFiles {$ELSE} Windows {$ENDIF}; + +{$R *.res} + +{$stackframes on} + +{The name of the 64-bit DLL has a '64' at the end.} +{$if SizeOf(Pointer) = 8} +{$LIBSUFFIX '64'} +{$ifend} + +{$if CompilerVersion <= 20} +type + NativeUInt = Cardinal; // not available or cause for internal compiler errors (e.g. Delphi 2009) + PNativeUInt = ^NativeUInt; +{$ifend} + +{--------------------------Stack Tracing Subroutines--------------------------} + +procedure GetStackRange(var AStackBaseAddress, ACurrentStackPointer: NativeUInt); +asm + {$if SizeOf(Pointer) = 8} + mov rax, gs:[abs 8] + mov [rcx], rax + mov [rdx], rbp + {$else} + mov ecx, fs:[4] + mov [eax], ecx + mov [edx], ebp + {$ifend} +end; + +{--------------------------Frame Based Stack Tracing--------------------------} + +{$if SizeOf(Pointer) = 8} + +function CaptureStackBackTrace(FramesToSkip, FramesToCapture: DWORD; + BackTrace: Pointer; BackTraceHash: PDWORD): Word; + external kernel32 name 'RtlCaptureStackBackTrace'; + +{We use the Windows API to do frame based stack tracing under 64-bit.} +procedure GetFrameBasedStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); +begin + CaptureStackBackTrace(ASkipFrames, AMaxDepth, AReturnAddresses, nil); +end; + +{$else} + +{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: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); +var + LStackTop, LStackBottom, LCurrentFrame: NativeUInt; +begin + {Get the call stack top and current bottom} + GetStackRange(LStackTop, LStackBottom); + Dec(LStackTop, SizeOf(Pointer) - 1); + {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^ := PNativeUInt(LCurrentFrame + SizeOf(Pointer))^; + Inc(AReturnAddresses); + Dec(AMaxDepth); + end + else + Dec(ASkipFrames); + {Get the next frame} + LCurrentFrame := PNativeUInt(LCurrentFrame)^; + end; + {Clear the remaining entries} + while AMaxDepth > 0 do + begin + AReturnAddresses^ := 0; + Inc(AReturnAddresses); + Dec(AMaxDepth); + end; +end; +{$ifend} + +{-----------------------------Raw Stack Tracing-----------------------------} + +const + {Hexadecimal characters} + HexTable: array[0..15] of AnsiChar = '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 (low) 4GB address space} + MemoryPageAccessMap: array[0..1024 * 1024 - 1] of TMemoryPageAccess; + +{$IFDEF MSWINDOWS} +{Updates the memory page access map. Currently only supports the low 4GB of + address space.} +procedure UpdateMemoryPageAccessMap(AAddress: NativeUInt); +var + LMemInfo: TMemoryBasicInformation; + LAccess: TMemoryPageAccess; + LStartPage, LPageCount: NativeUInt; +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 := NativeUInt(LMemInfo.BaseAddress) div 4096; + LPageCount := LMemInfo.RegionSize div 4096; + if LStartPage < NativeUInt(Length(MemoryPageAccessMap)) then + begin + if (LStartPage + LPageCount) >= NativeUInt(Length(MemoryPageAccessMap)) then + LPageCount := NativeUInt(Length(MemoryPageAccessMap)) - LStartPage; + FillChar(MemoryPageAccessMap[LStartPage], LPageCount, Ord(LAccess)); + end; + end + else + begin + {Invalid address} + MemoryPageAccessMap[AAddress div 4096] := mpaNotExecutable; + end; +end; +{$ENDIF} + +{Thread-safe version that avoids the global variable Default8087CW.} +procedure Set8087CW(ANewCW: Word); +var + L8087CW: Word; +asm + mov L8087CW, ANewCW + fnclex + fldcw L8087CW +end; + +{$if CompilerVersion > 22} +{Thread-safe version that avoids the global variable DefaultMXCSR.} +procedure SetMXCSR(ANewMXCSR: Cardinal); +var + LMXCSR: Cardinal; +asm + {$if SizeOf(Pointer) <> 8} + cmp System.TestSSE, 0 + je @exit + {$ifend} + {Remove the flag bits} + and ANewMXCSR, $ffc0 + mov LMXCSR, ANewMXCSR + ldmxcsr LMXCSR +@exit: +end; +{$ifend} + +{$IFDEF MSWINDOWS} +{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: NativeUInt): boolean; +var + LCallAddress: NativeUInt; + LCode8Back, LCode4Back, LTemp: Cardinal; + LOld8087CW: Word; +{$if CompilerVersion > 22} + LOldMXCSR: Cardinal; +{$ifend} +begin + {We assume (for now) that all code will execute within the first 4GB of + address space.} + if (AReturnAddress > $ffff) and (AReturnAddress <= $ffffffff) 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 + {Try to determine what kind of call it is (if any), more or less in order + of frequency of occurrence. (Code below taken from the Jedi Code Library + (jcl.sourceforge.net).) We need to retrieve the current floating point + control registers, since any external exception will reset it to the + DLL defaults which may not otherwise correspond to the defaults of the + main application (QC 107198).} + LOld8087CW := Get8087CW; +{$if CompilerVersion > 22} + LOldMXCSR := GetMXCSR; +{$ifend} + try + {5 bytes, CALL NEAR REL32} + if PByteArray(LCallAddress)[3] = $E8 then + begin + Result := True; + Exit; + end; + {Get the 4 bytes before the return address} + LCode4Back := PCardinal(LCallAddress + 4)^; + {2 byte call?} + LTemp := LCode4Back and $F8FF0000; + {2 bytes, CALL NEAR EAX} + if LTemp = $D0FF0000 then + begin + Result := True; + Exit; + end; + {2 bytes, CALL NEAR [EAX]} + if LTemp = $10FF0000 then + begin + LTemp := LCode4Back - LTemp; + if (LTemp <> $04000000) and (LTemp <> $05000000) then + begin + Result := True; + Exit; + end; + end; + {3 bytes, CALL NEAR [EAX+EAX*i]} + if (LCode4Back and $00FFFF00) = $0014FF00 then + begin + Result := True; + Exit; + end; + {3 bytes, CALL NEAR [EAX+$12]} + if ((LCode4Back and $00F8FF00) = $0050FF00) + and ((LCode4Back and $00070000) <> $00040000) then + begin + Result := True; + Exit; + end; + {4 bytes, CALL NEAR [EAX+EAX+$12]} + if Word(LCode4Back) = $54FF then + begin + Result := True; + Exit; + end; + {6 bytes, CALL NEAR [$12345678]} + LCode8Back := PCardinal(LCallAddress)^; + if (LCode8Back and $FFFF0000) = $15FF0000 then + begin + Result := True; + Exit; + end; + {6 bytes, CALL NEAR [EAX+$12345678]} + if ((LCode8Back and $F8FF0000) = $90FF0000) + and ((LCode8Back and $07000000) <> $04000000) then + begin + Result := True; + Exit; + end; + {7 bytes, CALL NEAR [EAX+EAX+$1234567]} + if (LCode8Back and $00FFFF00) = $0094FF00 then + begin + Result := True; + Exit; + end; + {7 bytes, CALL FAR $1234:12345678} + if (LCode8Back and $0000FF00) = $00009A00 then + begin + Result := True; + Exit; + end; + {Not a valid call site} + Result := False; + except + {The access has changed} + UpdateMemoryPageAccessMap(LCallAddress); + {The RTL sets the FPU control words to the default values if an + external exception occurs. Reset their values here to the values on + entry to this call.} + Set8087CW(LOld8087CW); +{$if CompilerVersion > 22} + SetMXCSR(LOldMXCSR); +{$ifend} + {Not executable} + Result := False; + end; + end + else + Result := False; + end + else + Result := False; +end; +{$ENDIF} + +{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.} + +{$IFDEF MACOS} +function backtrace(result: PNativeUInt; size: Integer): Integer; cdecl; external libc name '_backtrace'; +function _NSGetExecutablePath(buf: PAnsiChar; BufSize: PCardinal): Integer; cdecl; external libc name '__NSGetExecutablePath'; +{$ENDIF} + +procedure GetRawStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); +var + LStackTop, LStackBottom, LCurrentFrame, LNextFrame, LReturnAddress, + LStackAddress: NativeUInt; + LLastOSError: Cardinal; + +{$IFDEF MACOS} + StackLog: PNativeUInt; //array[0..10] of Pointer; + Cnt: Integer; + I: Integer; +{$ENDIF} +begin + {$IFDEF MACOS} + {$POINTERMATH ON} + Cnt := AMaxDepth + ASkipFrames; + + GetMem(StackLog, SizeOf(Pointer) * Cnt); + try + Cnt := backtrace(StackLog, Cnt); + + for I := ASkipFrames to Cnt - 1 do + begin +// writeln('Stack: ', inttohex(NativeUInt(stacklog[I]), 8)); + AReturnAddresses[I - ASkipFrames] := StackLog[I]; + end; + + finally + FreeMem(StackLog); + end; + {$POINTERMATH OFF} + {$ENDIF} + {Are exceptions being handled? Can only do a raw stack trace if the possible + access violations are going to be handled.} +{$IFDEF MSWINDOWS} + if Assigned(ExceptObjProc) then + begin + {Save the last Windows error code} + LLastOSError := GetLastError; + {Get the call stack top and current bottom} + GetStackRange(LStackTop, LStackBottom); + Dec(LStackTop, SizeOf(Pointer) - 1); + {Get the current frame start} + LCurrentFrame := LStackBottom; + {Fill the call stack} + while (AMaxDepth > 0) + and (LCurrentFrame < LStackTop) do + begin + {Get the next frame} + LNextFrame := PNativeUInt(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 := PNativeUInt(LCurrentFrame + SizeOf(Pointer))^; + {Does this appear to be a valid return address} + if (LReturnAddress > $ffff) and (LReturnAddress <= $ffffffff) then + begin + {Is the map for this return address incorrect? It may be unknown or marked + as non-executable 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 + 2 * SizeOf(Pointer); + while (AMaxDepth > 0) + and (LStackAddress < LNextFrame) do + begin + {Get the return address} + LReturnAddress := PNativeUInt(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, SizeOf(Pointer)); + end; + end; + {Do the next stack frame} + LCurrentFrame := LNextFrame; + end; + {Clear the remaining entries} + 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; + {$ENDIF} +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 an unsigned integer to a hexadecimal string at the buffer location, + returning the new buffer position.} +function NativeUIntToHexBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar; +const + MaxDigits = 16; +var + LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar; + LCount: Cardinal; + LDigit: NativeUInt; +begin + {Generate the digits in the local buffer} + LCount := 0; + repeat + LDigit := ANum; + ANum := ANum div 16; + LDigit := LDigit - ANum * 16; + Inc(LCount); + LDigitBuffer[MaxDigits - LCount] := HexTable[LDigit]; + until ANum = 0; + {Add leading zeros} + while LCount < SizeOf(NativeUInt) * 2 do + begin + Inc(LCount); + LDigitBuffer[MaxDigits - LCount] := '0'; + end; + {Copy the digits to the output buffer and advance it} + System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount); + Result := APBuffer + LCount; +end; + +{Subroutine used by LogStackTrace} +procedure AppendInfoToString(var AString: string; const AInfo: string); +begin + if AInfo <> '' then + AString := Format('%s[%s]', [AString, AInfo]); +end; + +function LogStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; + ABuffer: PAnsiChar): PAnsiChar; +var + LInd: Cardinal; + LAddress: NativeUInt; + LNumChars: Integer; + LInfo: TJCLLocationInfo; + LTempStr: string; + P: PChar; +begin + Result := ABuffer; + {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 5+ + {$IF declared(BeginGetLocationInfoCache)} // available depending on the JCL's version + BeginGetLocationInfoCache; + try + {$IFEND} + {$ENDIF} + for LInd := 0 to AMaxDepth - 1 do + begin + LAddress := AReturnAddresses^; + if LAddress = 0 then + Exit; + Result^ := #13; + Inc(Result); + Result^ := #10; + Inc(Result); + Result := NativeUIntToHexBuf(LAddress, Result); + {Get location info for the caller (at least one byte before the return + address).} + GetLocationInfo(Pointer(LAddress - 1), LInfo); + {Build the result string} + LTempStr := ' '; + AppendInfoToString(LTempStr, LInfo.SourceName); + AppendInfoToString(LTempStr, LInfo.UnitName); + + {Remove UnitName from ProcedureName, no need to output it twice} + P := PChar(LInfo.ProcedureName); + if (StrLComp(P, PChar(LInfo.UnitName), Length(LInfo.UnitName)) = 0) and (P[Length(LInfo.UnitName)] = '.') then + AppendInfoToString(LTempStr, Copy(LInfo.ProcedureName, Length(LInfo.UnitName) + 2)) + else + AppendInfoToString(LTempStr, LInfo.ProcedureName); + + if LInfo.LineNumber <> 0 then + AppendInfoToString(LTempStr, IntToStr(LInfo.LineNumber)); + {Return the result} + if Length(LTempStr) < 256 then + LNumChars := Length(LTempStr) + else + LNumChars := 255; + StrLCopy(Result, PAnsiChar(AnsiString(LTempStr)), LNumChars); + Inc(Result, LNumChars); + {Next address} + Inc(AReturnAddresses); + end; + {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 5+ + {$IF declared(BeginGetLocationInfoCache)} // available depending on the JCL's version + finally + EndGetLocationInfoCache; + end; + {$IFEND} + {$ENDIF} +end; +{$endif} + +{$ifdef madExcept} +function LogStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; +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: PNativeUInt; AMaxDepth: Cardinal; + ABuffer: PAnsiChar): PAnsiChar; +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} + +{$IFDEF MACOS} + +{Appends the source text to the destination and returns the new destination + position} +function AppendStringToBuffer(const ASource, ADestination: PAnsiChar; ACount: Cardinal): PAnsiChar; +begin + System.Move(ASource^, ADestination^, ACount); + Result := Pointer(PByte(ADestination) + ACount); +end; + +var + MapFile: TSBMapFile; + +function LogStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; +var + s1: AnsiString; + I: Integer; + FileName: array[0..255] of AnsiChar; + Len: Cardinal; +begin + {$POINTERMATH ON} +// writelN('LogStackTrace'); +// for I := 0 to AMaxDepth - 1 do +// Writeln(IntToHex(AReturnAddresses[I], 8)); + +// s1 := IntToHex(Integer(AReturnAddresses[0]), 8); +// result := ABuffer; +// Move(pointer(s1)^, result^, Length(s1)); +// inc(result, Length(s1)); + + if MapFile = nil then + begin + MapFile := TSBMapFile.Create; + Len := Length(FileName); + _NSGetExecutablePath(@FileName[0], @Len); + if FileExists(ChangeFileExt(FileName, '.map')) then + MapFile.LoadFromFile(ChangeFileExt(FileName, '.map')); + end; + + Result := ABuffer; + + s1 := #13#10; + Result := AppendStringToBuffer(PAnsiChar(s1), Result, Length(s1)); + + for I := 0 to AMaxDepth - 1 do + begin + s1 := IntToHex(AReturnAddresses[I], 8); + s1 := s1 + ' ' + MapFile.GetFunctionName(AReturnAddresses[I]) + #13#10; + Result := AppendStringToBuffer(PAnsiChar(s1), Result, Length(s1)); + end; + + {$POINTERMATH OFF} +end; +{$ENDIF} + +{-----------------------------Exported Functions----------------------------} + +exports + GetFrameBasedStackTrace, + GetRawStackTrace, + LogStackTrace; + +begin +{$ifdef JCLDebug} + JclStackTrackingOptions := JclStackTrackingOptions + [stAllModules]; +{$endif} +end. diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dproj b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dproj new file mode 100644 index 0000000..89eed18 --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.dproj @@ -0,0 +1,475 @@ + + + {990612ba-64b5-4560-bc82-798c7cdf11d3} + FastMM_FullDebugMode.dpr + Debug + DCC32 + FastMM_FullDebugMode.dll + None + 15.3 + True + Release + OSX32 + 7 + Library + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + None + true + 61 + System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) + 6 + true + 7177 + CompanyName=PSD / Pierre le Riche;FileDescription=FastMM FullDebugMode Support DLL;FileVersion=1.61.0.6;InternalName=;LegalCopyright=(c) Professional Software Development;LegalTrademarks=Licence: MPL 1.1;OriginalFilename=FastMM_FullDebugMode.dll;ProductName=FastMM FullDebugMode Support DLL;ProductVersion=1.60;Comments= + + + /usr/X11/bin/xterm -e "%debuggee%" + false + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + 0 + 0 + FullDebugMode_DLL_TestApp.exe + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + 0 + 0 + C:\Projects\CIMSO\Components\Current\PSD40\FastMM4\FullDebugMode DLL\FullDebugMode_DLL_TestApp.exe + System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + 7.0 + 0 + False + 0 + 3 + RELEASE;$(DCC_Define) + + + false + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + 1033 + 0 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 0 + + + 1033 + 0 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 0 + + + 7.0 + 3 + DEBUG;$(DCC_Define) + + + /Users/Sebastian/RADPAServer/scratch-dir/Sebastian-lsbx/Bug_DoubleFree/Bug_DoubleFree + true + /usr/X11/bin/xterm -e "%debuggee%" + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + false + + + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + true + + + Delphi.Personality.12 + VCLApplication + + + + False + True + False + + + True + False + 1 + 61 + 0 + 6 + False + False + False + False + False + 7177 + 1252 + + + PSD / Pierre le Riche + FastMM FullDebugMode Support DLL + 1.61.0.6 + + (c) Professional Software Development + Licence: MPL 1.1 + FastMM_FullDebugMode.dll + FastMM FullDebugMode Support DLL + 1.60 + + + + FastMM_FullDebugMode.dpr + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + True + True + + + + + + + + + + + + libFastMM_FullDebugMode.dylib.rsm + + + + + 1 + .dylib + + + 0 + .bpl + + + 1 + .dylib + + + 1 + .dylib + + + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + + + 1 + + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + 1 + + + 1 + + + + + + library\lib\armeabi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xhdpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 0 + + + + + + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + + 1 + + + 1 + + + + + + res\drawable + 1 + + + + + Contents\Resources + 1 + + + + + + 1 + + + 1 + + + + + 1 + + + library\lib\armeabi + 1 + + + 0 + + + 1 + + + 1 + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + 1 + + + 1 + + + + + res\drawable-ldpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + 1 + + + + + + + + + + + 12 + + + + + MainSource + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + + diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.info.plist b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode.info.plist new file mode 100644 index 0000000..e69de29 diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode_Icon.ico b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode_Icon.ico new file mode 100644 index 0000000..cfd8992 Binary files /dev/null and b/contrib/FastMM4-AVX/FullDebugMode DLL/FastMM_FullDebugMode_Icon.ico differ diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dpr b/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dpr new file mode 100644 index 0000000..7f0505f --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dpr @@ -0,0 +1,70 @@ +// JCL_DEBUG_EXPERT_INSERTJDBG ON +program FullDebugMode_DLL_TestApp; + +{$APPTYPE CONSOLE} + +{$R *.res} + +{$stackframes on} + +uses + System.SysUtils; + +const + {$if SizeOf(Pointer) = 8} + FullDebugModeLibraryName = 'FastMM_FullDebugMode64.dll'; + {$else} + FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; + {$ifend} + +const + MaxEntries = 20; + SkipFrames = 0; + TextBufSize = 64 * 1024; +var + LReturnAddresses: array[0..MaxEntries - 1] of NativeUInt; + LTextBuffer: array[0..TextBufSize - 1] of AnsiChar; + +{Procedures exported by the DLL that should be tested.} +procedure GetFrameBasedStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName; +procedure GetRawStackTrace(AReturnAddresses: PNativeUInt; + AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName; +function LogStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; + ABuffer: PAnsiChar): PAnsiChar; external FullDebugModeLibraryName; + +procedure TestFrameBasedStackTrace; +begin + FillChar(LReturnAddresses, SizeOf(LReturnAddresses), 0); + FillChar(LTextBuffer, SizeOf(LTextBuffer), 0); + + GetFrameBasedStackTrace(@LReturnAddresses, MaxEntries, SkipFrames); + LogStackTrace(@LReturnAddresses, MaxEntries, @LTextBuffer); + WriteLn(LTextBuffer); +end; + +procedure TestRawStackTrace; +begin + FillChar(LReturnAddresses, SizeOf(LReturnAddresses), 0); + FillChar(LTextBuffer, SizeOf(LTextBuffer), 0); + + GetRawStackTrace(@LReturnAddresses, MaxEntries, SkipFrames); + LogStackTrace(@LReturnAddresses, MaxEntries, @LTextBuffer); + WriteLn(LTextBuffer); +end; + +procedure RunTest; +begin + TestFrameBasedStackTrace; + TestRawStackTrace; +end; + +begin + try + RunTest; + ReadLn; + except + on E: Exception do + Writeln(E.ClassName, ': ', E.Message); + end; +end. diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dproj b/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dproj new file mode 100644 index 0000000..7892280 --- /dev/null +++ b/contrib/FastMM4-AVX/FullDebugMode DLL/FullDebugMode_DLL_TestApp.dproj @@ -0,0 +1,160 @@ + + + {C707C87D-D87C-425C-865F-60ADA26CA5BC} + 13.4 + None + FullDebugMode_DLL_TestApp.dpr + True + Debug + Win64 + 3 + Console + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + None + 7177 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + bindcompfmx;fmx;rtl;dbrtl;IndySystem;DbxClientDriver;bindcomp;inetdb;DBXInterBaseDriver;DataSnapCommon;DataSnapClient;DataSnapServer;DataSnapProviderClient;xmlrtl;DbxCommonDriver;IndyProtocols;DBXMySQLDriver;dbxcds;soaprtl;bindengine;DBXOracleDriver;dsnap;DBXInformixDriver;IndyCore;fmxase;DBXFirebirdDriver;inet;fmxobj;inetdbxpress;DBXSybaseASADriver;fmxdae;dbexpress;DataSnapIndy10ServerTransport;IPIndyImpl;$(DCC_UsePackage) + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + false + false + false + false + + + DBXOdbcDriver;DBXSybaseASEDriver;vclimg;vclactnband;vcldb;bindcompvcl;vcldsnap;Jcl;vclie;vcltouch;DBXDb2Driver;websnap;VclSmp;vcl;DBXMSSQLDriver;dsnapcon;vclx;webdsnap;JclDeveloperTools;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + vcldbx;TeeDB;vclib;inetdbbde;Tee;DBXOdbcDriver;svnui;ibxpress;DBXSybaseASEDriver;vclimg;vclactnband;FMXTee;vcldb;TeeUI;bindcompvcl;vcldsnap;Jcl;vclie;vcltouch;DBXDb2Driver;websnap;vclribbon;VclSmp;vcl;DataSnapConnectors;CloudService;DBXMSSQLDriver;FmxTeeUI;dsnapcon;vclx;webdsnap;svn;JclDeveloperTools;bdertl;adortl;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + false + true + true + true + + + 3 + + + 3 + None + 1033 + false + + + false + RELEASE;$(DCC_Define) + 0 + false + + + + MainSource + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 7177 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + FullDebugMode_DLL_TestApp.dpr + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + True + True + + + 12 + + + + diff --git a/contrib/FastMM4-AVX/FullDebugMode DLL/Precompiled/libFastMM_FullDebugMode.dylib b/contrib/FastMM4-AVX/FullDebugMode DLL/Precompiled/libFastMM_FullDebugMode.dylib new file mode 100644 index 0000000..d9f22a6 Binary files /dev/null and b/contrib/FastMM4-AVX/FullDebugMode DLL/Precompiled/libFastMM_FullDebugMode.dylib differ diff --git a/contrib/FastMM4-AVX/README.md b/contrib/FastMM4-AVX/README.md new file mode 100644 index 0000000..3ac9f7d --- /dev/null +++ b/contrib/FastMM4-AVX/README.md @@ -0,0 +1,416 @@ +# FastMM4-AVX + +FastMM4-AVX (efficient synchronization and AVX1/AVX2/AVX512/ERMS/FSRM support for FastMM4) + - Copyright (C) 2017-2020 Ritlabs, SRL. All rights reserved. + - Copyright (C) 2020-2021 Maxim Masiutin. All rights reserved. + +Written by Maxim Masiutin + +Version 1.0.6 + +This is a fork of the "Fast Memory Manager" (FastMM) v4.993 by Pierre le Riche +(see below for the original FastMM4 description) + +What was added to FastMM4-AVX in comparison to the original FastMM4: + + - Efficient synchronization + - improved synchronization between the threads; proper synchronization + techniques are used depending on context and availability, i.e., spin-wait + loops, SwitchToThread, critical sections, etc.; + - used the "test, test-and-set" technique for the spin-wait loops; this + technique is recommended by Intel (see Section 11.4.3 "Optimization with + Spin-Locks" of the Intel 64 and IA-32 Architectures Optimization Reference + Manual) to determine the availability of the synchronization variable; + according to this technique, the first "test" is done via the normal + (non-locking) memory load to prevent excessive bus locking on each + iteration of the spin-wait loop; if the variable is available upon + the normal memory load of the first step ("test"), proceed to the + second step ("test-and-set") which is done via the bus-locking atomic + "xchg" instruction; however, this two-steps approach of using "test" before + "test-and-set" can increase the cost for the un-contended case comparing + to just single-step "test-and-set", this may explain why the speed benefits + of the FastMM4-AVX are more pronounced when the memory manager is called + from multiple threads in parallel, while in single-threaded use scenario + there may be no benefit compared to the original FastMM4; + - the number of iterations of "pause"-based spin-wait loops is 5000, + before relinquishing to SwitchToThread(); + - see https://stackoverflow.com/a/44916975 for more details on the + implementation of the "pause"-based spin-wait loops; + - using normal memory store to release a lock: + FastMM4-AVX uses normal memory store, i.e., the "mov" instruction, rather + then the bus-locking "xchg" instruction to write into the synchronization + variable (LockByte) to "release a lock" on a data structure, + see https://stackoverflow.com/a/44959764 + for discussion on releasing a lock; + you man define "InterlockedRelease" to get the old behavior of the original + FastMM4. + - implemented dedicated lock and unlock procedures that operate with + synchronization variables (LockByte); + before that, locking operations were scattered throughout the code; + now the locking functions have meaningful names: + AcquireLockByte and ReleaseLockByte; + the values of the lock byte are now checked for validity when + FullDebugMode or DEBUG is defined, to detect cases when the same lock is + released twice, and other improper use of the lock bytes; + - added compile-time options "SmallBlocksLockedCriticalSection", + "MediumBlocksLockedCriticalSection" and "LargeBlocksLockedCriticalSection" + which are set by default (inside the FastMM4Options.inc file) as + conditional defines. If you undefine these options, you will get the + old locking mechanism of the original FastMM4 based on loops of Sleep() or + SwitchToThread(). + + - AVX, AVX2 or AVX512 instructions for faster memory copy + - if the CPU supports AVX or AVX2, use the 32-byte YMM registers + for faster memory copy, and if the CPU supports AVX-512, + use the 64-byte ZMM registers for even faster memory copy; + - please note that the effect of using AVX instruction in speed improvement is + negligible, compared to the effect brought by efficient synchronization; + sometimes AVX instructions can even slow down the program because of AVX-SSE + transition penalties and reduced CPU frequency caused by AVX-512 + instructions in some processors; use DisableAVX to turn AVX off completely + or use DisableAVX1/DisableAVX2/DisableAVX512 to disable separately certain + AVX-related instruction set from being compiled); + - if EnableAVX is defined, all memory blocks are aligned by 32 bytes, but + you can also use Align32Bytes define without AVX; please note that the memory + overhead is higher when the blocks are aligned by 32 bytes, because some + memory is lost by padding; however, if your CPU supports + "Fast Short REP MOVSB" (Ice Lake or newer), you can disable AVX, and align + by just 8 bytes, and this may even be faster because less memory is wasted + on alignment; + - with AVX, memory copy is secure - all XMM/YMM/ZMM registers used to copy + memory are cleared by vxorps/vpxor, so the leftovers of the copied memory + are not exposed in the XMM/YMM/ZMM registers; + - the code attempts to properly handle AVX-SSE transitions to not incur the + transition penalties, only call vzeroupper under AVX1, but not under AVX2 + since it slows down subsequent SSE code under Skylake / Kaby Lake; + - on AVX-512, writing to xmm16-xmm31 registers will not affect the turbo + clocks, and will not impose AVX-SSE transition penalties; therefore, when we + have AVX-512, we now only use x(y/z)mm16-31 registers. + + - Speed improvements due to code optimization and proper techniques + - if the CPU supports Enhanced REP MOVSB/STOSB (ERMS), use this feature + for faster memory copy (under 32 bit or 64-bit) (see the EnableERMS define, + on by default, use DisableERMS to turn it off); + - if the CPU supports Fast Short REP MOVSB (FSRM), uses this feature instead + of AVX; + - branch target alignment in assembly routines is only used when + EnableAsmCodeAlign is defined; Delphi incorrectly encodes conditional + jumps, i.e., use long, 6-byte instructions instead of just short, 2-byte, + and this may affect branch prediction, so the benefits of branch target + alignment may not outweigh the disadvantage of affected branch prediction, + see https://stackoverflow.com/q/45112065 + - compare instructions + conditional jump instructions are put together + to allow macro-op fusion (which happens since Core2 processors, when + the first instruction is a CMP or TEST instruction and the second + instruction is a conditional jump instruction); + - multiplication and division by a constant, which is a power of 2 + replaced to shl/shr, because Delphi64 compiler doesn't replace such + multiplications and divisions to shl/shr processor instructions, + and, according to the Intel Optimization Reference Manual, shl/shr is + faster than imul/idiv, at least for some processors. + + - Safer, cleaner code with stricter type adherence and better compatibility + - names assigned to some constants that used to be "magic constants", + i.e., unnamed numerical constants - plenty of them were present + throughout the whole code; + - removed some typecasts; the code is stricter to let the compiler + do the job, check everything and mitigate probable error. You can + even compile the code with "integer overflow checking" and + "range checking", as well as with "typed @ operator" - for safer + code. Also added round bracket in the places where the typed @ operator + was used, to better emphasize on who's address is taken; + - the compiler environment is more flexible now: you can now compile FastMM4 + with, for example, typed "@" operator or any other option. Almost all + externally-set compiler directives are honored by FastMM except a few + (currently just one) - look for the "Compiler options for FastMM4" section + below to see what options cannot be externally set and are always + redefined by FastMM4 for itself - even if you set up these compiler options + differently outside FastMM4, they will be silently + redefined, and the new values will be used for FastMM4 only; + - the type of one-byte synchronization variables (accessed via "lock cmpxchg" + or "lock xchg") replaced from Boolean to Byte for stricter type checking; + - those fixed-block-size memory move procedures that are not needed + (under the current bitness and alignment combinations) are + explicitly excluded from compiling, to not rely on the compiler + that is supposed to remove these function after compilation; + - added length parameter to what were the dangerous null-terminated string + operations via PAnsiChar, to prevent potential stack buffer overruns + (or maybe even stack-based exploitation?), and there some Pascal functions + also left, the argument is not yet checked. See the "todo" comments + to figure out where the length is not yet checked. Anyway, since these + memory functions are only used in Debug mode, i.e., in development + environment, not in Release (production), the impact of this + "vulnerability" is minimal (albeit this is a questionable statement); + - removed all non-US-ASCII characters, to avoid using UTF-8 BOM, for + better compatibility with very early versions of Delphi (e.g., Delphi 5), + thanks to Valts Silaputnins; + - support for Lazarus 1.6.4 with FreePascal (the original FastMM4 4.992 + requires modifications, it doesn't work under Lazarus 1.6.4 with FreePascal + out-of-the-box, also tested under Lazarus 1.8.2 / FPC 3.0.4 with Win32 + target; later versions should be also supported. + +Here are the comparison of the Original FastMM4 version 4.992, with default +options compiled for Win64 by Delphi 10.2 Tokyo (Release with Optimization), +and the current FastMM4-AVX branch ("AVX-br."). Under some multi-threading +scenarios, the FastMM4-AVX branch is more than twice as fast compared to the +Original FastMM4. The tests have been run on two different computers: one +under Xeon E5-2543v2 with 2 CPU sockets, each has 6 physical cores +(12 logical threads) - with only 5 physical core per socket enabled for the +test application. Another test was done under an i7-7700K CPU. + +Used the "Multi-threaded allocate, use and free" and "NexusDB" +test cases from the FastCode Challenge Memory Manager test suite, +modified to run under 64-bit. + + Xeon E5-2543v2 2*CPU i7-7700K CPU + (allocated 20 logical (8 logical threads, + threads, 10 physical 4 physical cores), + cores, NUMA), AVX-1 AVX-2 + + Orig. AVX-br. Ratio Orig. AVX-br. Ratio + ------ ----- ------ ----- ----- ------ + 02-threads realloc 96552 59951 62.09% 65213 49471 75.86% + 04-threads realloc 97998 39494 40.30% 64402 47714 74.09% + 08-threads realloc 98325 33743 34.32% 64796 58754 90.68% + 16-threads realloc 116273 45161 38.84% 70722 60293 85.25% + 31-threads realloc 122528 53616 43.76% 70939 62962 88.76% + 64-threads realloc 137661 54330 39.47% 73696 64824 87.96% + NexusDB 02 threads 122846 90380 73.72% 79479 66153 83.23% + NexusDB 04 threads 122131 53103 43.77% 69183 43001 62.16% + NexusDB 08 threads 124419 40914 32.88% 64977 33609 51.72% + NexusDB 12 threads 181239 55818 30.80% 83983 44658 53.18% + NexusDB 16 threads 135211 62044 43.61% 59917 32463 54.18% + NexusDB 31 threads 134815 48132 33.46% 54686 31184 57.02% + NexusDB 64 threads 187094 57672 30.25% 63089 41955 66.50% + +The above tests have been run on 14-Jul-2017. + +Here are some more test results (Compiled by Delphi 10.2 Update 3): + + Xeon E5-2667v4 2*CPU i9-7900X CPU + (allocated 32 logical (20 logical threads, + threads, 16 physical 10 physical cores), + cores, NUMA), AVX-2 AVX-512 + + Orig. AVX-br. Ratio Orig. AVX-br. Ratio + ------ ----- ------ ----- ----- ------ + 02-threads realloc 80544 60025 74.52% 66100 55854 84.50% + 04-threads realloc 80751 47743 59.12% 64772 40213 62.08% + 08-threads realloc 82645 32691 39.56% 62246 27056 43.47% + 12-threads realloc 89951 43270 48.10% 65456 25853 39.50% + 16-threads realloc 95729 56571 59.10% 67513 27058 40.08% + 31-threads realloc 109099 97290 89.18% 63180 28408 44.96% + 64-threads realloc 118589 104230 87.89% 57974 28951 49.94% + NexusDB 01 thread 160100 121961 76.18% 93341 95807 102.64% + NexusDB 02 threads 115447 78339 67.86% 77034 70056 90.94% + NexusDB 04 threads 107851 49403 45.81% 73162 50039 68.39% + NexusDB 08 threads 111490 36675 32.90% 70672 42116 59.59% + NexusDB 12 threads 148148 46608 31.46% 92693 53900 58.15% + NexusDB 16 threads 111041 38461 34.64% 66549 37317 56.07% + NexusDB 31 threads 123496 44232 35.82% 62552 34150 54.60% + NexusDB 64 threads 179924 62414 34.69% 83914 42915 51.14% + +The above tests (on Xeon E5-2667v4 and i9) have been done on 03-May-2018. + +Here is the single-threading performance comparison in some selected +scenarios between FastMM v5.03 dated May 12, 2021 and FastMM4-AVX v1.05 +dated May 20, 2021. FastMM4-AVX is compiled with default optinos. This +test is run on May 20, 2021, under Intel Core i7-1065G7 CPU, Ice Lake +microarchitecture, base frequency: 1.3 GHz, max turbo frequencey: 3.90 GHz, +4 cores, 8 threads. Compiled under Delphi 10.3 Update 3, 64-bit target. +Please note that these are the selected scenarios where FastMM4-AVX is +faster then FastMM5. In other scenarios, especially in multi-threaded +with heavy contention, FastMM5 is faster. + + FastMM5 AVX-br. Ratio + ------ ------ ------ + ReallocMem Small (1-555b) benchmark 1425 1135 79.65% + ReallocMem Medium (1-4039b) benchmark 3834 3309 86.31% + Block downsize 12079 10305 85.31% + Address space creep benchmark 13283 12571 94.64% + Address space creep (larger blocks) 16066 13879 86.39% + Single-threaded reallocate and use 4395 3960 90.10% + Single-threaded tiny reallocate and use 8766 7097 80.96% + Single-threaded allocate, use and free 13912 13248 95.23% + +You can find the program, used to generate the benchmark data, +at https://github.com/maximmasiutin/FastCodeBenchmark + +You can find the program, used to generate the benchmark data, +at https://github.com/maximmasiutin/FastCodeBenchmark + +FastMM4-AVX is released under a dual license, and you may choose to use it +under either the Mozilla Public License 2.0 (MPL 2.1, available from +https://www.mozilla.org/en-US/MPL/2.0/) or the GNU Lesser General Public +License Version 3, dated 29 June 2007 (LGPL 3, available from +https://www.gnu.org/licenses/lgpl.html). + +FastMM4-AVX is free software: you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +FastMM4-AVX is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with FastMM4-AVX (see license_lgpl.txt and license_gpl.txt) +If not, see . + + +FastMM4-AVX Version History: + +- 1.0.6 (25 August 2021) - it can now be compiled with any alignment (8, 16, 32) + regardless of the target (x86, x64) and whether inline assembly is used + or not; the "PurePascal" conditional define to disable inline assembly at + all, however, in this case, efficient locking would not work since it + uses inline assembly; FreePascal now uses the original FreePascal compiler + mode, rather than the Delphi compatibility mode as before; resolved many + FreePascal compiler warnings; supported branch target alignment + in FreePascal inline assembly; small block types now always have + block sizes of 1024 and 2048 bytes, while in previous versions + instead of 1024-byte blocks there were 1056-byte blocks, + and instead of 2048-byte blocks were 2176-byte blocks; + fixed Delphi compiler hints for 64-bit Release mode; Win32 and Win64 + versions compiled under Delphi and FreePascal passed the all the FastCode + validation suites. + +- 1.05 (20 May 2021) - improved speed of releasing memory blocks on higher thread + contention. It is also possible to compile FastMM4-AVX without a single + inline assembly code. Renamed some conditional defines to be self-explaining. + Rewritten some comments to be meaningful. Made it compile under FreePascal + for Linux 64-bit and 32-bit. Also made it compile under FreePascal for + Windows 32-bit and 64-bit. Memory move functions for 152, 184 and 216 bytes + were incorrect Linux. Move216AVX1 and Move216AVX2 Linux implementation had + invalid opcodes. Added support for the GetFPCHeapStatus(). Optimizations on + single-threaded performance. If you define DisablePauseAndSwitchToThread, + it will use EnterCriticalSection/LeaveCriticalSectin. An attempt to free a + memory block twice was not caught under 32-bit Delphi. Added SSE fixed block + copy routines for 32-bit targets. Added support for the "Fast Short REP MOVSB" + CPU feature. Removed redundant SSE code from 64-bit targets. +- 1.04 (O6 October 2020) - improved use of AVX-512 instructions to avoid turbo + clock reduction and SSE/AVX transition penalty; made explicit order of + parameters for GetCPUID to avoid calling convention ambiguity that could + lead to incorrect use of registers and finally crashes, i.e., under Linux; + improved explanations and comments, i.e., about the use of the + synchronization techniques. +- 1.03 (04 May 2018) - minor fixes for the debug mode, FPC compatibility + and code readability cosmetic fixes. +- 1.02 (07 November 2017) - added and tested support for the AVX-512 + instruction set. +- 1.01 (10 October 2017) - made the source code compile under Delphi5, + thanks to Valts Silaputnins. +- 1.00 (27 July 2017) - initial revision. + + +The original FastMM4 description follows: + +# FastMM4 +Fast Memory Manager + +Description: + A fast replacement memory manager for Embarcadero Delphi applications + that scales well under multi-threaded usage, is not prone to memory + fragmentation, and supports shared memory without the use of external .DLL + files. + +Homepage: + https://github.com/pleriche/FastMM4 + +Advantages: + - Fast + - Low overhead. FastMM is designed for an average of 5% and maximum of 10% + overhead per block. + - Supports up to 3GB of user mode address space under Windows 32-bit and 4GB + under Windows 64-bit. Add the "$SetPEFlags $20" option (in curly braces) + to your .dpr to enable this. + - Highly aligned memory blocks. Can be configured for either 8-byte or 16-byte + alignment. + - Good scaling under multi-threaded applications + - Intelligent reallocations. Avoids slow memory move operations through + not performing unneccesary downsizes and by having a minimum percentage + block size growth factor when an in-place block upsize is not possible. + - Resistant to address space fragmentation + - No external DLL required when sharing memory between the application and + external libraries (provided both use this memory manager) + - Optionally reports memory leaks on program shutdown. (This check can be set + to be performed only if Delphi is currently running on the machine, so end + users won't be bothered by the error message.) + - Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3. + +Usage: + Delphi: + Place this unit as the very first unit under the "uses" section in your + project's .dpr file. When sharing memory between an application and a DLL + (e.g. when passing a long string or dynamic array to a DLL function), both the + main application and the DLL must be compiled using this memory manager (with + the required conditional defines set). There are some conditional defines + (inside FastMM4Options.inc) that may be used to tweak the memory manager. To + enable support for a user mode address space greater than 2GB you will have to + use the EditBin* tool to set the LARGE_ADDRESS_AWARE flag in the EXE header. + This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the + application supports an address space larger than 2GB (up to 4GB). In Delphi 6 + and later you can also specify this flag through the compiler directive + {$SetPEFlags $20} + *The EditBin tool ships with the MS Visual C compiler. + C++ Builder: + Refer to the instructions inside FastMM4BCB.cpp. + + +# FastMM4 +Fast Memory Manager +![FastMM-Title.jpg with title only](images/FastMM-Title.jpg "FastMM-Title.jpg with title only") + +## Description: + A fast replacement memory manager for Embarcadero Delphi applications + that scales well under multi-threaded usage, is not prone to memory + fragmentation, and supports shared memory without the use of external .DLL + files. + +## Homepage: + https://github.com/pleriche/FastMM4 + +## Advantages: +* Fast +* Low overhead. FastMM is designed for an average of 5% and maximum of 10% + overhead per block. +* Supports up to 3GB of user mode address space under Windows 32-bit and 4GB + under Windows 64-bit. Add the "$SetPEFlags $20" option (in curly braces) + to your .dpr to enable this. +* Highly aligned memory blocks. Can be configured for either 8-byte or 16-byte + alignment. +* Good scaling under multi-threaded applications +* Intelligent reallocations. Avoids slow memory move operations through + not performing unneccesary downsizes and by having a minimum percentage + block size growth factor when an in-place block upsize is not possible. +* Resistant to address space fragmentation +* No external DLL required when sharing memory between the application and + external libraries (provided both use this memory manager) +* Optionally reports memory leaks on program shutdown. (This check can be set + to be performed only if Delphi is currently running on the machine, so end + users won't be bothered by the error message.) +* Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3. + +## Usage: +### Delphi: + Place this unit as the very first unit under the "uses" section in your + project's .dpr file. When sharing memory between an application and a DLL + (e.g. when passing a long string or dynamic array to a DLL function), both the + main application and the DLL must be compiled using this memory manager (with + the required conditional defines set). + + There are some conditional defines + (inside `FastMM4Options.inc`) that may be used to tweak the memory manager. To + enable support for a user mode address space greater than 2GB you will have to + use the EditBin* tool to set the `LARGE_ADDRESS_AWARE` flag in the EXE header. + This informs Windows x64 or Windows 32-bit (with the /3GB option set) that the + application supports an address space larger than 2GB (up to 4GB). In Delphi 6 + and later you can also specify this flag through the compiler directive + `{$SetPEFlags $20}` + + *The EditBin tool ships with the MS Visual C compiler. +### C++ Builder: + Refer to the instructions inside `FastMM4BCB.cpp`. + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpf b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpf new file mode 100644 index 0000000..45623a5 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpf @@ -0,0 +1,9 @@ +USEUNIT("DLLEntry.cpp"); +USEUNIT("FastMM4BCB.cpp"); +USEUNIT("FastMM4.pas"); +USEUNIT("BorlndMM_.pas"); +USEDEF("Export.def"); +//--------------------------------------------------------------------------- +This file is used by the project manager only and should be treated like the project file + + DllEntryPoint \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpr b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpr new file mode 100644 index 0000000..d38a741 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM.bpr @@ -0,0 +1,118 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=2052 +CodePage=936 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[HistoryLists\hlConditionals] +Count=1 +Item0=_DEBUG + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +HostApplication=F:\FastMM492\FastMM4\Replacement BorlndMM DLL\BCB5\Project1.exe +RemoteHost= +RemotePath= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=1 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Language] +ActiveLang= +ProjectLang= +RootDir= + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM_.pas b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM_.pas new file mode 100644 index 0000000..7900ada --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/BorlndMM_.pas @@ -0,0 +1,254 @@ +unit BorlndMM_; + +interface + +{--------------------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} + +{$OBJEXPORTALL OFF} + +function GetAllocMemCount: integer; +function GetAllocMemSize: integer; +procedure DumpBlocks; +function HeapRelease: Integer; +function HeapAddRef: Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysGetMem(Size: Integer): Pointer; +{$ifdef BDS2006AndUp} +function SysAllocMem(Size: Cardinal): Pointer; +{$endif} + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +function FreeMemory(P: Pointer): Integer; cdecl; +function GetMemory(Size: Integer): Pointer; cdecl; + +function GetHeapStatus: THeapStatus; +{$ifdef BDS2006AndUp} +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +{$endif} + +implementation + +{$ifndef UseRTLMM} +uses + FastMM4; +{$endif} + +{$OPTIMIZATION ON} +{$STACKFRAMES OFF} +{$RANGECHECKS OFF} +{$OVERFLOWCHECKS OFF} + +{$ifdef NoDebugInfo} + {$DEBUGINFO OFF} +{$endif} + +//Export: GetAllocMemCount +//Symbol: @Borlndmm@GetAllocMemCount$qqrv +function GetAllocMemCount: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemCount; +{$else} + Result := 0; +{$endif} +end; + +//Export: GetAllocMemSize +//Symbol: @Borlndmm@GetAllocMemSize$qqrv +function GetAllocMemSize: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemSize; +{$else} + Result := 0; +{$endif} +end; + +//Export: DumpBlocks +//Symbol: @Borlndmm@DumpBlocks$qqrv +procedure DumpBlocks; +begin + {Do nothing} +end; + +//Export: @Borlndmm@HeapRelease$qqrv +//Symbol: @Borlndmm@HeapRelease$qqrv +function HeapRelease: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: @Borlndmm@HeapAddRef$qqrv +//Symbol: @Borlndmm@HeapAddRef$qqrv +function HeapAddRef: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: GetHeapStatus +//Symbol: @Borlndmm@GetHeapStatus$qqrv +function GetHeapStatus: THeapStatus; +begin +{$ifndef UseRTLMM} + Result := FastGetHeapStatus; +{$else} + Result := System.GetHeapStatus; +{$endif} +end; + + +//Export: ReallocMemory +//Symbol: @Borlndmm@ReallocMemory$qpvi +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := System.ReallocMemory(P, Size); +end; + +//Export: FreeMemory +//Symbol: @Borlndmm@FreeMemory$qpv +function FreeMemory(P: Pointer): Integer; cdecl; +begin + Result := System.FreeMemory(P); +end; + +//Export: GetMemory +//Symbol: @Borlndmm@GetMemory$qi +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := System.GetMemory(Size); +end; + + +//Export: @Borlndmm@SysReallocMem$qqrpvi +//Symbol: @Borlndmm@SysReallocMem$qqrpvi +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastReallocMem(P, Size); + {$else} + Result := DebugReallocMem(P, Size); + {$endif} +{$else} + Result := System.SysReallocMem(P, Size); +{$endif} +end; + +//Export: @Borlndmm@SysFreeMem$qqrpv +//Symbol: @Borlndmm@SysFreeMem$qqrpv +function SysFreeMem(P: Pointer): Integer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastFreeMem(P); + {$else} + Result := DebugFreeMem(P); + {$endif} +{$else} + Result := System.SysFreeMem(P); +{$endif} +end; + +//Export: @Borlndmm@SysGetMem$qqri +//Symbol: @Borlndmm@SysGetMem$qqri +function SysGetMem(Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastGetMem(Size); + {$else} + Result := DebugGetMem(Size); + {$endif} +{$else} + Result := System.SysGetMem(Size); +{$endif} +end; + +//Export: @Borlndmm@SysAllocMem$qqri +//Symbol: @Borlndmm@SysAllocMem$qqrui +function SysAllocMem(Size: Cardinal): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastAllocMem(Size); + {$else} + Result := DebugAllocMem(Size); + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysAllocMem(Size); + {$ifend} + {$if RTLVersion < 18} + Result := System.AllocMem(Size); + {$ifend} +{$endif} +end; + + +//Export: @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := UnregisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysUnregisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +//Export: @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@RegisterExpectedMemoryLeak$qqrpv +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := RegisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysRegisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +initialization + IsMultiThread := True; +finalization +end. diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/DLLEntry.cpp b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/DLLEntry.cpp new file mode 100644 index 0000000..4c1c100 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/DLLEntry.cpp @@ -0,0 +1,31 @@ +//--------------------------------------------------------------------------- + +#include +//--------------------------------------------------------------------------- +// Important note about DLL memory management when your DLL uses the +// static version of the RunTime Library: +// +// If your DLL exports any functions that pass String objects (or structs/ +// classes containing nested Strings) as parameter or function results, +// you will need to add the library MEMMGR.LIB to both the DLL project and +// any other projects that use the DLL. You will also need to use MEMMGR.LIB +// if any other projects which use the DLL will be performing new or delete +// operations on any non-TObject-derived classes which are exported from the +// DLL. Adding MEMMGR.LIB to your project will change the DLL and its calling +// EXE's to use the BORLNDMM.DLL as their memory manager. In these cases, +// the file BORLNDMM.DLL should be deployed along with your DLL. +// +// To avoid using BORLNDMM.DLL, pass string information using "char *" or +// ShortString parameters. +// +// If your DLL uses the dynamic version of the RTL, you do not need to +// explicitly add MEMMGR.LIB as this will be done implicitly for you +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void* lpReserved) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/Export.def b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/Export.def new file mode 100644 index 0000000..18373a3 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB5/Export.def @@ -0,0 +1,29 @@ +LIBRARY BORLNDMM.DLL + +EXPORTS + GetAllocMemCount = @Borlndmm_@GetAllocMemCount$qqrv ;To make it the 2nd export, ___CPPdebugHook always the 1st export + GetAllocMemSize = @Borlndmm_@GetAllocMemSize$qqrv + GetHeapStatus = @Borlndmm_@GetHeapStatus$qqrv + DumpBlocks = @Borlndmm_@DumpBlocks$qqrv + ReallocMemory = @Borlndmm_@ReallocMemory$qpvi + FreeMemory = @Borlndmm_@FreeMemory$qpv + GetMemory = @Borlndmm_@GetMemory$qi + + ;@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi = @Borlndmm_@UnregisterExpectedMemoryLeak$qqrpv + ;@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi = @Borlndmm_@RegisterExpectedMemoryLeak$qqrpv + + ;@Borlndmm@SysAllocMem$qqri = @Borlndmm_@SysAllocMem$qqrui + @Borlndmm@SysReallocMem$qqrpvi = @Borlndmm_@SysReallocMem$qqrpvi + @Borlndmm@SysFreeMem$qqrpv = @Borlndmm_@SysFreeMem$qqrpv + @Borlndmm@SysGetMem$qqri = @Borlndmm_@SysGetMem$qqri + + @Borlndmm@HeapRelease$qqrv = @Borlndmm_@HeapRelease$qqrv + @Borlndmm@HeapAddRef$qqrv = @Borlndmm_@HeapAddRef$qqrv + + ;SetMMLogFileName = @Fastmm4@SetMMLogFileName$qqrpc + ;GetCurrentAllocationGroup = @Fastmm4@GetCurrentAllocationGroup$qqrv + ;PushAllocationGroup = @Fastmm4@PushAllocationGroup$qqrui + ;PopAllocationGroup = @Fastmm4@PopAllocationGroup$qqrv + ;LogAllocatedBlocksToFile = @Fastmm4@LogAllocatedBlocksToFile$qqruiui + + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpf b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpf new file mode 100644 index 0000000..67f3241 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpf @@ -0,0 +1,3 @@ +This file is used by the project manager only and should be treated like the project file + + DllEntryPoint \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpr b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpr new file mode 100644 index 0000000..ab9069e --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM.bpr @@ -0,0 +1,140 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=2052 +CodePage=936 + +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= + +[HistoryLists\hlIncludePath] +Count=1 +Item0=F:\FastMM492\FastMM4\Replacement BorlndMM DLL\BCB6;$(BCB)\include;$(BCB)\include\vcl + +[HistoryLists\hlLibraryPath] +Count=1 +Item0=F:\FastMM492\FastMM4\Replacement BorlndMM DLL\BCB6;$(BCB)\lib\obj;$(BCB)\lib + +[HistoryLists\hlDebugSourcePath] +Count=1 +Item0=$(BCB)\source\vcl + +[HistoryLists\hlConditionals] +Count=1 +Item0=_DEBUG + +[Debugging] +DebugSourceDirs=$(BCB)\source\vcl + +[Parameters] +RunParams= +Launcher= +UseLauncher=0 +DebugCWD= +HostApplication= +RemoteHost= +RemotePath= +RemoteLauncher= +RemoteCWD= +RemoteDebug=0 + +[Compiler] +ShowInfoMsgs=0 +LinkDebugVcl=1 +LinkCGLIB=0 + +[CORBA] +AddServerUnit=1 +AddClientUnit=1 +PrecompiledHeaders=1 + +[Linker] +LibPrefix= +LibSuffix= +LibVersion= + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM_.pas b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM_.pas new file mode 100644 index 0000000..7900ada --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/BorlndMM_.pas @@ -0,0 +1,254 @@ +unit BorlndMM_; + +interface + +{--------------------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} + +{$OBJEXPORTALL OFF} + +function GetAllocMemCount: integer; +function GetAllocMemSize: integer; +procedure DumpBlocks; +function HeapRelease: Integer; +function HeapAddRef: Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysGetMem(Size: Integer): Pointer; +{$ifdef BDS2006AndUp} +function SysAllocMem(Size: Cardinal): Pointer; +{$endif} + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +function FreeMemory(P: Pointer): Integer; cdecl; +function GetMemory(Size: Integer): Pointer; cdecl; + +function GetHeapStatus: THeapStatus; +{$ifdef BDS2006AndUp} +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +{$endif} + +implementation + +{$ifndef UseRTLMM} +uses + FastMM4; +{$endif} + +{$OPTIMIZATION ON} +{$STACKFRAMES OFF} +{$RANGECHECKS OFF} +{$OVERFLOWCHECKS OFF} + +{$ifdef NoDebugInfo} + {$DEBUGINFO OFF} +{$endif} + +//Export: GetAllocMemCount +//Symbol: @Borlndmm@GetAllocMemCount$qqrv +function GetAllocMemCount: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemCount; +{$else} + Result := 0; +{$endif} +end; + +//Export: GetAllocMemSize +//Symbol: @Borlndmm@GetAllocMemSize$qqrv +function GetAllocMemSize: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemSize; +{$else} + Result := 0; +{$endif} +end; + +//Export: DumpBlocks +//Symbol: @Borlndmm@DumpBlocks$qqrv +procedure DumpBlocks; +begin + {Do nothing} +end; + +//Export: @Borlndmm@HeapRelease$qqrv +//Symbol: @Borlndmm@HeapRelease$qqrv +function HeapRelease: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: @Borlndmm@HeapAddRef$qqrv +//Symbol: @Borlndmm@HeapAddRef$qqrv +function HeapAddRef: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: GetHeapStatus +//Symbol: @Borlndmm@GetHeapStatus$qqrv +function GetHeapStatus: THeapStatus; +begin +{$ifndef UseRTLMM} + Result := FastGetHeapStatus; +{$else} + Result := System.GetHeapStatus; +{$endif} +end; + + +//Export: ReallocMemory +//Symbol: @Borlndmm@ReallocMemory$qpvi +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := System.ReallocMemory(P, Size); +end; + +//Export: FreeMemory +//Symbol: @Borlndmm@FreeMemory$qpv +function FreeMemory(P: Pointer): Integer; cdecl; +begin + Result := System.FreeMemory(P); +end; + +//Export: GetMemory +//Symbol: @Borlndmm@GetMemory$qi +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := System.GetMemory(Size); +end; + + +//Export: @Borlndmm@SysReallocMem$qqrpvi +//Symbol: @Borlndmm@SysReallocMem$qqrpvi +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastReallocMem(P, Size); + {$else} + Result := DebugReallocMem(P, Size); + {$endif} +{$else} + Result := System.SysReallocMem(P, Size); +{$endif} +end; + +//Export: @Borlndmm@SysFreeMem$qqrpv +//Symbol: @Borlndmm@SysFreeMem$qqrpv +function SysFreeMem(P: Pointer): Integer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastFreeMem(P); + {$else} + Result := DebugFreeMem(P); + {$endif} +{$else} + Result := System.SysFreeMem(P); +{$endif} +end; + +//Export: @Borlndmm@SysGetMem$qqri +//Symbol: @Borlndmm@SysGetMem$qqri +function SysGetMem(Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastGetMem(Size); + {$else} + Result := DebugGetMem(Size); + {$endif} +{$else} + Result := System.SysGetMem(Size); +{$endif} +end; + +//Export: @Borlndmm@SysAllocMem$qqri +//Symbol: @Borlndmm@SysAllocMem$qqrui +function SysAllocMem(Size: Cardinal): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastAllocMem(Size); + {$else} + Result := DebugAllocMem(Size); + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysAllocMem(Size); + {$ifend} + {$if RTLVersion < 18} + Result := System.AllocMem(Size); + {$ifend} +{$endif} +end; + + +//Export: @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := UnregisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysUnregisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +//Export: @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@RegisterExpectedMemoryLeak$qqrpv +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := RegisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysRegisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +initialization + IsMultiThread := True; +finalization +end. diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/DLLEntry.cpp b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/DLLEntry.cpp new file mode 100644 index 0000000..dbcaca8 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/DLLEntry.cpp @@ -0,0 +1,31 @@ +//--------------------------------------------------------------------------- + +#include +//--------------------------------------------------------------------------- +// Important note about DLL memory management when your DLL uses the +// static version of the RunTime Library: +// +// If your DLL exports any functions that pass String objects (or structs/ +// classes containing nested Strings) as parameter or function results, +// you will need to add the library MEMMGR.LIB to both the DLL project and +// any other projects that use the DLL. You will also need to use MEMMGR.LIB +// if any other projects which use the DLL will be performing new or delete +// operations on any non-TObject-derived classes which are exported from the +// DLL. Adding MEMMGR.LIB to your project will change the DLL and its calling +// EXE's to use the BORLNDMM.DLL as their memory manager. In these cases, +// the file BORLNDMM.DLL should be deployed along with your DLL. +// +// To avoid using BORLNDMM.DLL, pass string information using "char *" or +// ShortString parameters. +// +// If your DLL uses the dynamic version of the RTL, you do not need to +// explicitly add MEMMGR.LIB as this will be done implicitly for you +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void* lpReserved) +{ + return 1; +} +//--------------------------------------------------------------------------- + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/Export.def b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/Export.def new file mode 100644 index 0000000..18373a3 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/BCB6/Export.def @@ -0,0 +1,29 @@ +LIBRARY BORLNDMM.DLL + +EXPORTS + GetAllocMemCount = @Borlndmm_@GetAllocMemCount$qqrv ;To make it the 2nd export, ___CPPdebugHook always the 1st export + GetAllocMemSize = @Borlndmm_@GetAllocMemSize$qqrv + GetHeapStatus = @Borlndmm_@GetHeapStatus$qqrv + DumpBlocks = @Borlndmm_@DumpBlocks$qqrv + ReallocMemory = @Borlndmm_@ReallocMemory$qpvi + FreeMemory = @Borlndmm_@FreeMemory$qpv + GetMemory = @Borlndmm_@GetMemory$qi + + ;@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi = @Borlndmm_@UnregisterExpectedMemoryLeak$qqrpv + ;@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi = @Borlndmm_@RegisterExpectedMemoryLeak$qqrpv + + ;@Borlndmm@SysAllocMem$qqri = @Borlndmm_@SysAllocMem$qqrui + @Borlndmm@SysReallocMem$qqrpvi = @Borlndmm_@SysReallocMem$qqrpvi + @Borlndmm@SysFreeMem$qqrpv = @Borlndmm_@SysFreeMem$qqrpv + @Borlndmm@SysGetMem$qqri = @Borlndmm_@SysGetMem$qqri + + @Borlndmm@HeapRelease$qqrv = @Borlndmm_@HeapRelease$qqrv + @Borlndmm@HeapAddRef$qqrv = @Borlndmm_@HeapAddRef$qqrv + + ;SetMMLogFileName = @Fastmm4@SetMMLogFileName$qqrpc + ;GetCurrentAllocationGroup = @Fastmm4@GetCurrentAllocationGroup$qqrv + ;PushAllocationGroup = @Fastmm4@PushAllocationGroup$qqrui + ;PopAllocationGroup = @Fastmm4@PopAllocationGroup$qqrv + ;LogAllocatedBlocksToFile = @Fastmm4@LogAllocatedBlocksToFile$qqruiui + + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bdsproj b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bdsproj new file mode 100644 index 0000000..8e12fc2 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bdsproj @@ -0,0 +1,263 @@ + + + + + + + + + + + + BorlndMM.bpf + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 2052 + 936 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + False + + + + + + + False + + False + + True + False + + + + + + + + + + + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bpf b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bpf new file mode 100644 index 0000000..7e758b1 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.bpf @@ -0,0 +1,5 @@ +This file is used by the project manager only and should be treated like the project file + +To add a file to this project use the Project menu 'Add to Project' + +DllEntryPoint \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.pas b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.pas new file mode 100644 index 0000000..9f2ae0f --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/BorlndMM.pas @@ -0,0 +1,248 @@ +unit BorlndMM; + +interface + +{--------------------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} + +function GetAllocMemCount: integer; +function GetAllocMemSize: integer; +procedure DumpBlocks; +function HeapRelease: Integer; +function HeapAddRef: Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysGetMem(Size: Integer): Pointer; +function SysAllocMem(Size: Cardinal): Pointer; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +function FreeMemory(P: Pointer): Integer; cdecl; +function GetMemory(Size: Integer): Pointer; cdecl; + +function GetHeapStatus: THeapStatus; deprecated; platform; +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; + +implementation + +{$ifndef UseRTLMM} +uses + FastMM4; +{$endif} + +{$OPTIMIZATION ON} +{$STACKFRAMES OFF} +{$RANGECHECKS OFF} +{$OVERFLOWCHECKS OFF} + +{$ifdef NoDebugInfo} + {$DEBUGINFO OFF} +{$endif} + +//Export: GetAllocMemCount +//Symbol: @Borlndmm@GetAllocMemCount$qqrv +function GetAllocMemCount: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemCount; +{$else} + Result := 0; +{$endif} +end; + +//Export: GetAllocMemSize +//Symbol: @Borlndmm@GetAllocMemSize$qqrv +function GetAllocMemSize: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemSize; +{$else} + Result := 0; +{$endif} +end; + +//Export: DumpBlocks +//Symbol: @Borlndmm@DumpBlocks$qqrv +procedure DumpBlocks; +begin + {Do nothing} +end; + +//Export: @Borlndmm@HeapRelease$qqrv +//Symbol: @Borlndmm@HeapRelease$qqrv +function HeapRelease: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: @Borlndmm@HeapAddRef$qqrv +//Symbol: @Borlndmm@HeapAddRef$qqrv +function HeapAddRef: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: GetHeapStatus +//Symbol: @Borlndmm@GetHeapStatus$qqrv +function GetHeapStatus: THeapStatus; deprecated; platform; +begin +{$ifndef UseRTLMM} + Result := FastGetHeapStatus; +{$else} + Result := System.GetHeapStatus; +{$endif} +end; + + +//Export: ReallocMemory +//Symbol: @Borlndmm@ReallocMemory$qpvi +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := System.ReallocMemory(P, Size); +end; + +//Export: FreeMemory +//Symbol: @Borlndmm@FreeMemory$qpv +function FreeMemory(P: Pointer): Integer; cdecl; +begin + Result := System.FreeMemory(P); +end; + +//Export: GetMemory +//Symbol: @Borlndmm@GetMemory$qi +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := System.GetMemory(Size); +end; + + +//Export: @Borlndmm@SysReallocMem$qqrpvi +//Symbol: @Borlndmm@SysReallocMem$qqrpvi +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastReallocMem(P, Size); + {$else} + Result := DebugReallocMem(P, Size); + {$endif} +{$else} + Result := System.SysReallocMem(P, Size); +{$endif} +end; + +//Export: @Borlndmm@SysFreeMem$qqrpv +//Symbol: @Borlndmm@SysFreeMem$qqrpv +function SysFreeMem(P: Pointer): Integer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastFreeMem(P); + {$else} + Result := DebugFreeMem(P); + {$endif} +{$else} + Result := System.SysFreeMem(P); +{$endif} +end; + +//Export: @Borlndmm@SysGetMem$qqri +//Symbol: @Borlndmm@SysGetMem$qqri +function SysGetMem(Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastGetMem(Size); + {$else} + Result := DebugGetMem(Size); + {$endif} +{$else} + Result := System.SysGetMem(Size); +{$endif} +end; + +//Export: @Borlndmm@SysAllocMem$qqri +//Symbol: @Borlndmm@SysAllocMem$qqrui +function SysAllocMem(Size: Cardinal): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastAllocMem(Size); + {$else} + Result := DebugAllocMem(Size); + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysAllocMem(Size); + {$ifend} + {$if RTLVersion < 18} + Result := System.AllocMem(Size); + {$ifend} +{$endif} +end; + + +//Export: @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := UnregisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysUnregisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +//Export: @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@RegisterExpectedMemoryLeak$qqrpv +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := RegisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysRegisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +initialization + IsMultiThread := True; +finalization +end. diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/DLLEntry.cpp b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/DLLEntry.cpp new file mode 100644 index 0000000..68fccf0 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/DLLEntry.cpp @@ -0,0 +1,30 @@ +//--------------------------------------------------------------------------- + +#include +//--------------------------------------------------------------------------- +// Important note about DLL memory management when your DLL uses the +// static version of the RunTime Library: +// +// If your DLL exports any functions that pass String objects (or structs/ +// classes containing nested Strings) as parameter or function results, +// you will need to add the library MEMMGR.LIB to both the DLL project and +// any other projects that use the DLL. You will also need to use MEMMGR.LIB +// if any other projects which use the DLL will be performing new or delete +// operations on any non-TObject-derived classes which are exported from the +// DLL. Adding MEMMGR.LIB to your project will change the DLL and its calling +// EXE's to use the BORLNDMM.DLL as their memory manager. In these cases, +// the file BORLNDMM.DLL should be deployed along with your DLL. +// +// To avoid using BORLNDMM.DLL, pass string information using "char *" or +// ShortString parameters. +// +// If your DLL uses the dynamic version of the RTL, you do not need to +// explicitly add MEMMGR.LIB as this will be done implicitly for you +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void* lpReserved) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Export.def b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Export.def new file mode 100644 index 0000000..f1f43ab --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Export.def @@ -0,0 +1,29 @@ +LIBRARY BORLNDMM.DLL + +EXPORTS + GetAllocMemCount = @Borlndmm@GetAllocMemCount$qqrv ;To make it the 2nd export, ___CPPdebugHook always the 1st export + GetAllocMemSize = @Borlndmm@GetAllocMemSize$qqrv + GetHeapStatus = @Borlndmm@GetHeapStatus$qqrv + DumpBlocks = @Borlndmm@DumpBlocks$qqrv + ReallocMemory = @Borlndmm@ReallocMemory$qpvi + FreeMemory = @Borlndmm@FreeMemory$qpv + GetMemory = @Borlndmm@GetMemory$qi + + @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi = @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv + @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi = @Borlndmm@RegisterExpectedMemoryLeak$qqrpv + + @Borlndmm@SysAllocMem$qqri = @Borlndmm@SysAllocMem$qqrui + @Borlndmm@SysReallocMem$qqrpvi + @Borlndmm@SysFreeMem$qqrpv + @Borlndmm@SysGetMem$qqri + + @Borlndmm@HeapRelease$qqrv + @Borlndmm@HeapAddRef$qqrv + + SetMMLogFileName = @Fastmm4@SetMMLogFileName$qqrpc + GetCurrentAllocationGroup = @Fastmm4@GetCurrentAllocationGroup$qqrv + PushAllocationGroup = @Fastmm4@PushAllocationGroup$qqrui + PopAllocationGroup = @Fastmm4@PopAllocationGroup$qqrv + LogAllocatedBlocksToFile = @Fastmm4@LogAllocatedBlocksToFile$qqruiui + + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Readme.txt b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Readme.txt new file mode 100644 index 0000000..dc451c4 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2006/Readme.txt @@ -0,0 +1 @@ +LoadDebugDLLDynamically must be defined. \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.cbproj b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.cbproj new file mode 100644 index 0000000..760583b --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.cbproj @@ -0,0 +1,91 @@ + + + + {b05d99db-d463-46a2-bf3a-7c9c13305544} + Debug + + + true + + + true + true + Base + + + true + true + Base + + + dll + true + NO_STRICT + JPHN + BCB + BorlandMM + true + CppDynamicLibrary + rtl.bpi;vclx.bpi;vcl.bpi;vclactnband.bpi;xmlrtl.bpi;bcbsmp.bpi;dbrtl.bpi;vcldb.bpi;dsnap.bpi;dsnapcon.bpi;adortl.bpi;dbxcds.bpi;dbexpress.bpi;DbxCommonDriver.bpi;VclSmp.bpi + false + 0x21150000 + $(BDS)\include;$(BDS)\include\dinkumware;$(BDS)\include\vcl;BorlndMM + rtl.lib + $(BDS)\lib;$(BDS)\lib\obj;$(BDS)\lib\psdk;BorlndMM + true + + + false + false + _DEBUG;$(Defines) + true + true + false + true + None + DEBUG + true + true + true + $(BDS)\lib\debug;$(ILINK_LibraryPath) + true + Full + true + + + NDEBUG;$(Defines) + Release + $(BDS)\lib\release;$(ILINK_LibraryPath) + None + + + CPlusPlusBuilder.Personality + CppDynamicLibrary + +FalseFalse1000FalseFalseFalseFalseFalse20529361.0.0.01.0.0.0FalseFalseFalseTrueFalseFalseTrueTrue2$(BDS)\include;$(BDS)\include\dinkumware;$(BDS)\include\vcl;BorlndMM$(BDS)\include;$(BDS)\include\dinkumware;$(BDS)\include\vcl;BorlandMM1$(BDS)\lib;$(BDS)\lib\obj;$(BDS)\lib\psdk;BorlndMM1NO_STRICT1010x2001409610x211500000x0040000010x0000100010x0010000010x0000200010x001000001012502..\Host\Debug\..\TestAPP\Debug\1BCB + + + + + 0 + + + 1 + + + 3 + + + 2 + + + 4 + + + Cfg_1 + + + Cfg_2 + + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.pas b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.pas new file mode 100644 index 0000000..9f2ae0f --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/BorlndMM.pas @@ -0,0 +1,248 @@ +unit BorlndMM; + +interface + +{--------------------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} + +function GetAllocMemCount: integer; +function GetAllocMemSize: integer; +procedure DumpBlocks; +function HeapRelease: Integer; +function HeapAddRef: Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysGetMem(Size: Integer): Pointer; +function SysAllocMem(Size: Cardinal): Pointer; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +function FreeMemory(P: Pointer): Integer; cdecl; +function GetMemory(Size: Integer): Pointer; cdecl; + +function GetHeapStatus: THeapStatus; deprecated; platform; +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; + +implementation + +{$ifndef UseRTLMM} +uses + FastMM4; +{$endif} + +{$OPTIMIZATION ON} +{$STACKFRAMES OFF} +{$RANGECHECKS OFF} +{$OVERFLOWCHECKS OFF} + +{$ifdef NoDebugInfo} + {$DEBUGINFO OFF} +{$endif} + +//Export: GetAllocMemCount +//Symbol: @Borlndmm@GetAllocMemCount$qqrv +function GetAllocMemCount: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemCount; +{$else} + Result := 0; +{$endif} +end; + +//Export: GetAllocMemSize +//Symbol: @Borlndmm@GetAllocMemSize$qqrv +function GetAllocMemSize: integer; +begin + {Return stats for the RTL MM only} +{$ifdef UseRTLMM} + Result := System.AllocMemSize; +{$else} + Result := 0; +{$endif} +end; + +//Export: DumpBlocks +//Symbol: @Borlndmm@DumpBlocks$qqrv +procedure DumpBlocks; +begin + {Do nothing} +end; + +//Export: @Borlndmm@HeapRelease$qqrv +//Symbol: @Borlndmm@HeapRelease$qqrv +function HeapRelease: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: @Borlndmm@HeapAddRef$qqrv +//Symbol: @Borlndmm@HeapAddRef$qqrv +function HeapAddRef: Integer; +begin + {Do nothing} + Result := 2; +end; + +//Export: GetHeapStatus +//Symbol: @Borlndmm@GetHeapStatus$qqrv +function GetHeapStatus: THeapStatus; deprecated; platform; +begin +{$ifndef UseRTLMM} + Result := FastGetHeapStatus; +{$else} + Result := System.GetHeapStatus; +{$endif} +end; + + +//Export: ReallocMemory +//Symbol: @Borlndmm@ReallocMemory$qpvi +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := System.ReallocMemory(P, Size); +end; + +//Export: FreeMemory +//Symbol: @Borlndmm@FreeMemory$qpv +function FreeMemory(P: Pointer): Integer; cdecl; +begin + Result := System.FreeMemory(P); +end; + +//Export: GetMemory +//Symbol: @Borlndmm@GetMemory$qi +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := System.GetMemory(Size); +end; + + +//Export: @Borlndmm@SysReallocMem$qqrpvi +//Symbol: @Borlndmm@SysReallocMem$qqrpvi +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastReallocMem(P, Size); + {$else} + Result := DebugReallocMem(P, Size); + {$endif} +{$else} + Result := System.SysReallocMem(P, Size); +{$endif} +end; + +//Export: @Borlndmm@SysFreeMem$qqrpv +//Symbol: @Borlndmm@SysFreeMem$qqrpv +function SysFreeMem(P: Pointer): Integer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastFreeMem(P); + {$else} + Result := DebugFreeMem(P); + {$endif} +{$else} + Result := System.SysFreeMem(P); +{$endif} +end; + +//Export: @Borlndmm@SysGetMem$qqri +//Symbol: @Borlndmm@SysGetMem$qqri +function SysGetMem(Size: Integer): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastGetMem(Size); + {$else} + Result := DebugGetMem(Size); + {$endif} +{$else} + Result := System.SysGetMem(Size); +{$endif} +end; + +//Export: @Borlndmm@SysAllocMem$qqri +//Symbol: @Borlndmm@SysAllocMem$qqrui +function SysAllocMem(Size: Cardinal): Pointer; +begin +{$ifndef UseRTLMM} + {$ifndef FullDebugMode} + Result := FastAllocMem(Size); + {$else} + Result := DebugAllocMem(Size); + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysAllocMem(Size); + {$ifend} + {$if RTLVersion < 18} + Result := System.AllocMem(Size); + {$ifend} +{$endif} +end; + + +//Export: @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv +function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := UnregisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysUnregisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +//Export: @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi +//Symbol: @Borlndmm@RegisterExpectedMemoryLeak$qqrpv +function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; +begin +{$ifndef UseRTLMM} + {$ifdef EnableMemoryLeakReporting} + Result := RegisterExpectedMemoryLeak(ALeakedPointer); + {$else} + Result := False; + {$endif} +{$else} + //{$ifdef VER180} + {$if RTLVersion >= 18} + Result := System.SysRegisterExpectedMemoryLeak(ALeakedPointer); + {$ifend} + {$if RTLVersion < 18} + Result := False; + {$ifend} +{$endif} +end; + +initialization + IsMultiThread := True; +finalization +end. diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/DLLEntry.cpp b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/DLLEntry.cpp new file mode 100644 index 0000000..68fccf0 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/DLLEntry.cpp @@ -0,0 +1,30 @@ +//--------------------------------------------------------------------------- + +#include +//--------------------------------------------------------------------------- +// Important note about DLL memory management when your DLL uses the +// static version of the RunTime Library: +// +// If your DLL exports any functions that pass String objects (or structs/ +// classes containing nested Strings) as parameter or function results, +// you will need to add the library MEMMGR.LIB to both the DLL project and +// any other projects that use the DLL. You will also need to use MEMMGR.LIB +// if any other projects which use the DLL will be performing new or delete +// operations on any non-TObject-derived classes which are exported from the +// DLL. Adding MEMMGR.LIB to your project will change the DLL and its calling +// EXE's to use the BORLNDMM.DLL as their memory manager. In these cases, +// the file BORLNDMM.DLL should be deployed along with your DLL. +// +// To avoid using BORLNDMM.DLL, pass string information using "char *" or +// ShortString parameters. +// +// If your DLL uses the dynamic version of the RTL, you do not need to +// explicitly add MEMMGR.LIB as this will be done implicitly for you +//--------------------------------------------------------------------------- + +#pragma argsused +int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void* lpReserved) +{ + return 1; +} +//--------------------------------------------------------------------------- diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Export.def b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Export.def new file mode 100644 index 0000000..f1f43ab --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Export.def @@ -0,0 +1,29 @@ +LIBRARY BORLNDMM.DLL + +EXPORTS + GetAllocMemCount = @Borlndmm@GetAllocMemCount$qqrv ;To make it the 2nd export, ___CPPdebugHook always the 1st export + GetAllocMemSize = @Borlndmm@GetAllocMemSize$qqrv + GetHeapStatus = @Borlndmm@GetHeapStatus$qqrv + DumpBlocks = @Borlndmm@DumpBlocks$qqrv + ReallocMemory = @Borlndmm@ReallocMemory$qpvi + FreeMemory = @Borlndmm@FreeMemory$qpv + GetMemory = @Borlndmm@GetMemory$qi + + @Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi = @Borlndmm@UnregisterExpectedMemoryLeak$qqrpv + @Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi = @Borlndmm@RegisterExpectedMemoryLeak$qqrpv + + @Borlndmm@SysAllocMem$qqri = @Borlndmm@SysAllocMem$qqrui + @Borlndmm@SysReallocMem$qqrpvi + @Borlndmm@SysFreeMem$qqrpv + @Borlndmm@SysGetMem$qqri + + @Borlndmm@HeapRelease$qqrv + @Borlndmm@HeapAddRef$qqrv + + SetMMLogFileName = @Fastmm4@SetMMLogFileName$qqrpc + GetCurrentAllocationGroup = @Fastmm4@GetCurrentAllocationGroup$qqrv + PushAllocationGroup = @Fastmm4@PushAllocationGroup$qqrui + PopAllocationGroup = @Fastmm4@PopAllocationGroup$qqrv + LogAllocatedBlocksToFile = @Fastmm4@LogAllocatedBlocksToFile$qqruiui + + diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Readme.txt b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Readme.txt new file mode 100644 index 0000000..dc451c4 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/CB2007/Readme.txt @@ -0,0 +1 @@ +LoadDebugDLLDynamically must be defined. \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dpr b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dpr new file mode 100644 index 0000000..9efe2e0 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dpr @@ -0,0 +1,182 @@ +{ + +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 in 'FastMM4.pas', + FastMM4Messages in 'FastMM4Messages.pas'; + +{$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/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dproj b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dproj new file mode 100644 index 0000000..cd52bf3 --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/BorlndMM.dproj @@ -0,0 +1,74 @@ + + + {b2046f52-e024-4415-9fc4-47822f5d8392} + BorlndMM.dpr + Debug + AnyCPU + DCC32 + BorlndMM.dll + + + 7.0 + False + False + 0 + 3 + D20000 + borlndmmdll;debugdll;dllforide;RELEASE + False + + + 7.0 + 3 + D20000 + borlndmmdll;debugdll;dllforide;DEBUG + False + + + Delphi.Personality + VCLApplication + + + False + True + False + + + 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 + + + BorlndMM.dpr + + + + + + + MainSource + + + + \ No newline at end of file diff --git a/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/FastMMDebugSupport.pas b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/FastMMDebugSupport.pas new file mode 100644 index 0000000..da66fea --- /dev/null +++ b/contrib/FastMM4-AVX/Replacement BorlndMM DLL/Delphi/FastMMDebugSupport.pas @@ -0,0 +1,50 @@ +{ + +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: PAnsiChar = nil); +{Returns the current "allocation group". Whenever a GetMem request is serviced + in FullDebugMode, the current "allocation group" is stored in the block header. + This may help with debugging. Note that if a block is subsequently reallocated + that it keeps its original "allocation group" and "allocation number" (all + allocations are also numbered sequentially).} +function GetCurrentAllocationGroup: Cardinal; +{Allocation groups work in a stack like fashion. Group numbers are pushed onto + and popped off the stack. Note that the stack size is limited, so every push + should have a matching pop.} +procedure PushAllocationGroup(ANewCurrentAllocationGroup: Cardinal); +procedure PopAllocationGroup; +{Logs detail about currently allocated memory blocks for the specified range of + allocation groups. if ALastAllocationGroupToLog is less than + AFirstAllocationGroupToLog or it is zero, then all allocation groups are + logged. This routine also checks the memory pool for consistency at the same + time.} +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/contrib/FastMM4-AVX/Translations/Afrikaans/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Afrikaans/FastMM4Messages.pas new file mode 100644 index 0000000..38ce325 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Afrikaans/FastMM4Messages.pas @@ -0,0 +1,134 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Onbekend'; + {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. '; + FreeModifiedDetailMsg = #13#10#13#10'Die veranderde grepe begin posisies (en aantal) is: '; + DoubleFreeErrorMsg = '''n Poging is aangewend om ''n ongebruikte blok vry te stel of te herallokeer.'; + WrongMMFreeErrorMsg = '''n Poging is aangewend om ''n blok vry te stel of te herallokeer wat deur ''n ander FastMM instansie geallokeer is. Ondersoek jou FastMM deel verstellings.'; + PreviousBlockSizeMsg = #13#10#13#10'Die vorige blok grootte was: '; + CurrentBlockSizeMsg = #13#10#13#10'Die blok grootte is: '; + 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: '; + BlockErrorMsgTitle = 'Geheue Fout'; + 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'Die huidige thread ID is 0x'; + CurrentStackTraceMsg = ', en die stapel spoor (terugkeer adresse) wat gelei het tot die fout is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'Die blok is voorheen geallokeer deur thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'Die blok is geallokeer deur thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'Die blok is voorheen vrygestel deur thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'Die objek is geallokeer deur thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'Die objek is daarna vrygestel deur thread 0x'; + StackTraceMsg = ', en die stapel spoor (terugkeer adresse) was toe:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 is alreeds geïnstalleer.'; + AlreadyInstalledTitle = 'Alreeds geïnstalleer.'; + OtherMMInstalledMsg = 'FastMM4 kan nie geïnstalleer word nie, want ''n ander ' + + 'derde party geheuebestuurder is alreeds geïnstalleer.'#13#10'Indien jy FastMM4 wil gebruik, ' + + 'verseker asb. dat FastMM4.pas die eerste leêr is in die "uses"' + + #13#10'afdeling van jou projek se .dpr leêr.'; + OtherMMInstalledTitle = 'FastMM4 kan nie geïnstalleer word nie - ''n ander geheue bestuurder is alreeds geïnstalleer'; + MemoryAllocatedMsg = 'FastMM4 kan nie geïnstalleer word nie aangesien geheue reeds ' + + 'geallokeer is deur die verstek geheue bestuurder.'#13#10'FastMM4.pas MOET ' + + 'die eerste leêr wees in jou projek se .dpr leêr, 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 geïnisialiseer word.'; + MemoryAllocatedTitle = 'FastMM4 kan nie geïnstalleer 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: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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 leêr in dieselfde gids as hierdie program. ' + {$else} + + 'Sit "LogMemoryLeakDetailToFile" aan om ''n gedetailleerde verslag oor al die geheue lekkasies na teksleêr te skryf. ' + {$endif} + {$else} + + 'Sit die "FullDebugMode" en "LogMemoryLeakDetailToFile" opsies aan om ''n gedetailleerde verslag oor al die geheue lekkasies na teksleêr 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/contrib/FastMM4-AVX/Translations/Belarussian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Belarussian/FastMM4Messages.pas new file mode 100644 index 0000000..0974934 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Belarussian/FastMM4Messages.pas @@ -0,0 +1,136 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unknown'; + {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 âûÿâ³¢ øòî áëîê áû¢ ìàäûô³êàâàíû ïàñëÿ ÿãî âûçâàëåííÿ. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Áûëà ðàñïà÷àòà ñïðîáà âûçâàë³öü/ïåðàâûçâàë³öü íåâûëó÷àíû áëîê.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Ïàìåð ïàïÿðýäíÿãà áëîêà áû¢: '; + CurrentBlockSizeMsg = #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: '; + BlockErrorMsgTitle = 'Âûÿ¢ëåíàÿ ïàìûëêà ïàìÿö³.'; + VirtualMethodErrorHeader = 'FastMM âûÿâ³¢ ñïðîáó âûêë³êàöü â³ðòóàëüíû ìåòàä âûçâàëåíàãà àá''åêòà. Çàðàç áóäçå âûêë³êàíà ïàðóøýííå äîñòóïó äëÿ ïåðàïûíåííÿ áÿãó÷àé àïåðàöû³.'; + InterfaceErrorHeader = 'FastMM âûÿâ³¢ ñïðîáó âûêàðûñòàöü ³íòýðôåéñ âûçâàëåíàãà àá''åêòà. Çàðàç áóäçå âûêë³êàíà ïàðóøýííå äîñòóïó äëÿ ïåðàïûíåííÿ áÿãó÷àé àïåðàöû³.'; + BlockHeaderCorruptedNoHistoryMsg = ' Íàæàëü çàãàëîâàê áëîêà ïàøêîäæàíû ³ ã³ñòîðûÿ íå äàñòóïíàÿ.'; + FreedObjectClassMsg = #13#10#13#10'Êëàñ âûçâàëåíàãà àá''åêòà: '; + VirtualMethodName = #13#10#13#10'³ðòóàëüíû ìåòàä: '; + VirtualMethodOffset = 'Çðóøýííå +'; + VirtualMethodAddress = #13#10#13#10'Àäðàñ â³ðòóàëüíàãà ìåòàäó: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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 = ' áàéòà¢: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Messages.pas new file mode 100644 index 0000000..df2aa13 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Messages.pas @@ -0,0 +1,131 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'δ֪'; + {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 ¼ì²âµ½¶ÔÒÑÊÍ·ÅÄÚ´æ¿éÄÚÈݵÄÐÞ¸Ä. '; + FreeModifiedDetailMsg = #13#10#13#10'±»ÐÞ¸Ä×Ö½ÚµÄÆ«ÒƵØÖ·(ÒÔ¼°³¤¶È): '; + DoubleFreeErrorMsg = 'ÊÔͼÊÍ·Å/ÖØзÖÅäÒ»¸öÉÐδ·ÖÅäµÄÄÚ´æ¿é.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'ÉÏ´ÎʹÓÃʱµÄÄÚ´æ¿é´óСÊÇ: '; + CurrentBlockSizeMsg = #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'·ÖÅäºÅÂëÊÇ: '; + BlockErrorMsgTitle = '¼ì²âµ½ÄÚ´æ´íÎó'; + VirtualMethodErrorHeader = 'FastMM ¼ì²âµ½¶ÔÒÑÊͷŶÔÏóµÄÐé·½·¨µÄµ÷ÓÃ. Ò»¸ö·ÃÎʳåÍ»Òì³£ÏÖÔÚ½«±»Òý·¢ÒÔÖÐÖ¹µ±Ç°µÄ²Ù×÷.'; + InterfaceErrorHeader = 'FastMM ¼ì²âµ½¶ÔÒÑÊͷŶÔÏóµÄ½Ó¿ÚµÄʹÓÃ. Ò»¸ö·ÃÎʳåÍ»Òì³£ÏÖÔÚ½«±»Òý·¢ÒÔÖÐÖ¹µ±Ç°µÄ²Ù×÷.'; + BlockHeaderCorruptedNoHistoryMsg = ' ²»ÐÒµØ, ÓÉÓÚÄÚ´æ¿éÍ·²¿µÄÄÚÈÝÒѱ»ÆÆ»µ, ÎÞ·¨µÃµ½¸ÃÄÚ´æ¿éµÄʹÓÃÀúÊ·.'; + FreedObjectClassMsg = #13#10#13#10'±»ÊͷŵĶÔÏóËùÊôµÄÀà: '; + VirtualMethodName = #13#10#13#10'Ðé·½·¨: '; + VirtualMethodOffset = 'Æ«ÒƵØÖ· +'; + VirtualMethodAddress = #13#10#13#10'Ðé·½·¨µÄµØÖ·: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'µ±Ç°Ïß³ÌµÄ ID ÊÇ 0x'; + CurrentStackTraceMsg = ', µ¼Ö¸ôíÎóµÄ¶ÑÕ»¸ú×Ù(·µ»ØµØÖ·): '; + ThreadIDPrevAllocMsg = #13#10#13#10'¸ÃÄÚ´æ¿éÉÏÒ»´Î·ÖÅäÓÚÏß³Ì 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'¸ÃÄÚ´æ¿é·ÖÅäÓÚÏß³Ì 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'¸ÃÄÚ´æ¿éÉÏÒ»´ÎÊÍ·ÅÓÚÏß³Ì 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'¸Ã¶ÔÏó·ÖÅäÓÚÏß³Ì 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'¸Ã¶ÔÏóËæºóÊÍ·ÅÓÚÏß³Ì 0x'; + StackTraceMsg = ', µ±Ê±µÄ¶ÑÕ»¸ú×Ù(·µ»ØµØÖ·): '; + {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 = ' ×Ö½Ú: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Options.inc b/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Options.inc new file mode 100644 index 0000000..2e0b1ee --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Chinese (Simplified)/FastMM4Options.inc @@ -0,0 +1,372 @@ +{ + +Fast Memory Manager: Ñ¡ÏîÅäÖÃÎļþ + +ÔÚÕâÀïΪFastMMÉèÖÃĬÈÏÑ¡Ïî + +FastMM 4.97 + +} + +{ + Simplified Chinese translation by QianYuan Wang + + Contact me if you find any improper translation. + Èç¹û·­ÒëÉÏÓÐÈκβ»Ç¡µ±µÄµØ·½ÇëºÍÎÒÁªÏµ¡£ + + E-Mail: wqyfavor@qq.com +} + +{ + ¶Ô¸÷±àÒëÑ¡ÏîµÄ·­Ò루²»½âÊÍÊõÓ + + Align16Bytes °´16×Ö½Ú¶ÔÆë + UseCustomFixedSizeMoveRoutines ʹÓù̶¨³ß´çÄÚ´æÒƶ¯º¯Êý + UseCustomVariableSizeMoveRoutines ʹÓÿɱä³ß´çÄÚ´æÒƶ¯º¯Êý + AssumeMultiThreaded °´¶àÏ̴߳¦Àí + NeverSleepOnThreadContention Ï̳߳åͻʱ²»ÔÝÍ£½ø³Ì + InstallOnlyIfRunningInIDE ½öÔÚDelphi¿ª·¢»·¾³ÖмÓÔØÄÚ´æ¹ÜÀíÆ÷ + NeverUninstall ²»Ð¶ÔØFastMM + UseRuntimePackages ʹÓÃÔËÐÐÆÚ°ü + + NoDebugInfo ÎÞµ÷ÊÔÐÅÏ¢ + NoMessageBoxes ²»ÏÔʾÐÅÏ¢ + UseOutputDebugString ʹÓÃWindows API OutputDebugString + ASMVersion »ã±à°æ±¾ + CheckHeapForCorruption ¼ì²â¶Ñ´íÎó + DetectMMOperationsAfterUninstall ¼ì²âÔÚ¹ÜÀíÆ÷жÔغó¶ÔÆäµÄÒýÓòÙ×÷ + FullDebugMode È«µ÷ÊÔģʽ + RawStackTraces ³¹µ×µÄÕ»×·×Ù + CatchUseOfFreedInterfaces ²¶×½¶ÔÒÑÏú»Ù¶ÔÏóµÄÒýÓà + LogErrorsToFile ¼Ç¼´íÎóµ½Îļþ + LogMemoryLeakDetailToFile ¼Ç¼ÄÚ´æй¶ϸ½Úµ½Îļþ + ClearLogFileOnStartup Æô¶¯Ê±Çå¿ÕÈÕÖ¾Îļþ + LoadDebugDLLDynamically ¶¯Ì¬¼ÓÔص÷ÊÔDll + AlwaysAllocateTopDown ×Ü´Ó×¶Ë·ÖÅäÄÚ´æ + + EnableMemoryLeakReporting ÔÊÐíÄÚ´æ鶱¨¸æ + HideExpectedLeaksRegisteredByPointer Òþ²ØÓÉÖ¸Õë¼Ç¼µÄ¿ÉÄܵÄÄÚ´æй¶ + RequireIDEPresenceForLeakReporting ½öÔÚIDE´æÔÚʱ½øÐÐ鶱¨¸æ + RequireDebuggerPresenceForLeakReporting ½öÔÚµ÷ÊÔÆ÷´æÔÚʱ½øÐÐ鶱¨¸æ + RequireDebugInfoForLeakReporting 鶱¨¸æÐèÒªµ÷ÊÔÐÅÏ¢ + ManualLeakReportingControl ÊÖ¹¤¿ØÖÆ鶱¨¸æ + HideMemoryLeakHintMessage Òþ²ØÄÚ´æй¶ÌáʾÐÅÏ¢ + + EnableMMX ÔÊÐíʹÓÃMMX + ForceMMX Ç¿ÖÆʹÓÃMMX + + ShareMM ¹²ÏíÄÚ´æ¹ÜÀíÆ÷ + ShareMMIfLibrary ÔÊÐíÔÚDllÖй²ÏíÄÚ´æ¹ÜÀíÆ÷ + AttemptToUseSharedMM ³¢ÊÔ¹²ÏíÄÚ´æ¹ÜÀíÆ÷ + EnableBackwardCompatibleMMSharing ÔÊÐíÏòºó¼æÈݵÄÄÚ´æ¹ÜÀíÆ÷¹²Ïí + + FullDebugModeInIDE ÔÚDelphi¿ª·¢»·¾³ÖнøÐÐÈ«µ÷ÊÔ +} + +{--------------------------- ×ÛºÏÑ¡Ïî -----------------------------} + +{¿ªÆô´ËÑ¡Ïî»á½«ËùÓÐÄÚ´æ¿é°´16×Ö½Ú¶ÔÆëÒÔ±ãSSEÖ¸Áî¿ÉÒÔ°²È«Ê¹Óá£Èç¹û´ËÑ¡Ïî¹Ø±Õ£¬Ò»Ð© + ×îСµÄÄÚ´æ¿é»á°´8×Ö½Ú·½Ê½¶ÔÆ룬Õ⽫¼õÉÙÄÚ´æʹÓᣲ»¹ÜÊÇ·ñ¿ªÆô´ËÑ¡ÏÖеȺʹóµÄÄÚ + ´æ¿é¶¼½«°´ÕÕ16×Ö½Ú·½Ê½¶ÔÆë¡£} +{.$define Align16Bytes} + +{ÔÊÐíÔÚÔö´óСÄÚ´æ¿éʱʹÓøü¿ìµÄ¶¨³ß´çÄÚ´æÒƶ¯º¯Êý¡£ÒòΪÕâЩº¯Êý±»Éè¼ÆΪÒƶ¯¹Ì¶¨³ß´ç + Äڴ棬ËùÒÔЧÂÊ´ó·ù¸ßÓÚBorlandµÄRTLÖеÄÄÚ´æÒƶ¯º¯Êý¡£ÕâһѡÏî¿ÉÓëFastMove¿âÅäºÏʹÓà + À´´ïµ½¸ü¸ßµÄЧÂÊ¡£} +{$define UseCustomFixedSizeMoveRoutines} + +{¿ªÆô´ËÑ¡ÏîÒÔʹÓÃÓÅ»¯µÄº¯ÊýÀ´Òƶ¯ÈÎÒâ´óСµÄÄÚ´æ¿é¡£Ê¹ÓÃFastcodeµÄFastMoveº¯Êýʱ½ûÓà + ´ËÑ¡ÏʹÓÃFastMove´úÂë¿ÉÒÔʹÕû¸ö³ÌÐò¶¼Ê¹Óõ½¸ü¿ìµÄÄÚ´æÒƶ¯º¯Êý¶ø²»½ö½öÊÇÄÚ´æ¹ÜÀí + Æ÷¡£Òò´Ë½¨Ò齫FastMMºÍFastMove´úÂëÏà½áºÏ£¬²¢¹Ø±Õ´ËÑ¡Ïî¡£} +{$define UseCustomVariableSizeMoveRoutines} + +{¿ªÆô´ËÑ¡Ïî»áʹ³ÌÐò½öÔÚDelphi IDEÄÚÔËÐÐʱ²Å¼Ó²ÃFastMM×÷ΪÄÚ´æ¹ÜÀíÆ÷¡£µ±ÄãÏ£Íû·¢²¼µÄ + Exe¾ÍÊÇÄãµ÷ÊÔµÄExe£¬µ«Ö»Ï£ÍûÔÚ¿ª·¢Ö÷»úÉÏʹÓõ÷ÊÔʱÇ뿪Æô´ËÑ¡Ïî¡£µ±¿ªÆôºó³ÌÐòÓÖ²¢²» + ÔÚ¿ª·¢Ö÷»úÉÏÔËÐУ¬Ëü»áʹÓÃĬÈϵÄDelphiÄÚ´æ¹ÜÀíÆ÷£¨ÔÚDelphi2006ÒÔºóÊDz»¿ªÆôFullDebugMode + µÄFastMM£©} +{.$define InstallOnlyIfRunningInIDE} + +{ÓÉÓÚQC#14070£¨Delphi³¢ÊÔÔÚborlandmm.dllµÄ¹Ø±ÕÖ¸ÁîÖ´ÐкóÊÍ·ÅÄڴ棩£¬µ±Ê¹ÓÃÁËFastMM + ΪºËÐĵÄborlandmm.dllµÄÌæ´úÆ·£¬FastMM²»Äܱ»Õý³£Ð¶ÔØ¡£¿ªÆô´ËÑ¡Ïî»á²»Ð¶ÔØÄÚ´æ¹ÜÀíÆ÷ + ¶ø±Ü¿ªÕâ¸ö´íÎó¡£} +{.$define NeverUninstall} + +{Èç¹ûÔÚµ±Ç°¹¤³ÌÖÐʹÓÃÁËÔËÐÐÆڵİü£¬ÐèÒªÆô¶¯Õâ¸öÑ¡Ïî¡£»á×Ô¶¯¿ªÆôAssumeMultiThreaded¡£ + ×¢ÒâÄã±ØÐëÈ·±£ÔÚËùÓÐÖ¸Õ붼ÊͷźóFastMM±»Ð¶ÔØ¡£Èç¹û²»Õâô×ö»á²úÉúÒ»¸öÓкܶàA/VµÄ¾Þ + ´óµÄÄÚ´æ鶱¨¸æ¡££¨²Î¿¼³£¼ûÎÊÌ⣩Äã±ØÐëͬʱÆô¶¯´ËÑ¡ÏîºÍNeverUninstallÑ¡Ïî¡£} +{.$define UseRuntimePackages} + +{-----------------------Concurrency Management Options------------------------} + +{¿ªÆôºó½«Ä¬ÈϳÌÐòÊǶàÏ̵߳ģ¬µ«»áµ¼Öµ¥Ï̳߳ÌÐòËÙ¶ÈÃ÷ÏÔϽµ¡£ÔÚʹÓÿÉÄÜδÕýÈ·Éè + ÖÃIsMultiThread±äÁ¿µÄ¶àÏ̵߳ĵÚÈý·½¹¤¾ßʱÇ뿪Æô´ËÑ¡Ïî¡£ÔÚµ¥Ïß³ÌÖ÷³ÌÐòºÍ¶àÏß³ÌDll + ¼ä¹²ÏíÄÚ´æ¹ÜÀíÆ÷ʱҲÐ迪Æô¡£} +{.$define AssumeMultiThreaded} + +{¿ªÆô´ËÑ¡Ï²»»áÔÚÏ̳߳åͻʱÈÃÒ»¸öÏß³ÌÔÝÍ££¬Ôڻ½ø³ÌÓëCPUºËÐÄÊýÄ¿±ÈµÍ£¨Ð¡ÓÚ2£©Ê± + ½«»áÌáÉýËٶȡ£¿ªÆôºó£¬³åͻʱһ¸öÏ߳̽«»á½øÈë¡°µÈ´ý¡±Ñ­»·¶ø²»Êǽ»³öʱ¼äƬ¡£} +{.$define NeverSleepOnThreadContention} + + {¿ªÆôºó£¬µ±Ï̳߳åͻʱ»áµ÷ÓÃSwitchToThread¶ø²»ÊÇһֱͣÁôÔÚ¡°µÈ´ý¡±Ñ­»·ÖС£Õâ¸öÑ¡ÏîÐèÒª + ÅäºÏNeverSleepOnThreadContentionÒ»ÆðʹÓ㬲¢ÇÒ±ØÐëÔÚÇ°Õß¿ªÆôʱ²ÅÓÐЧ¡£µ±ÏµÍ³Óжà¸ö + CPUºËÐÄ»òÏß³ÌÓв»Í¬µÄÓÅÏȼ¶Ê±£¬¿ªÆô´ËÑ¡Ïî¿ÉÌá¸ßЧÂÊ¡£SwitchToThreadµ÷ÓÃÖ»ÔÚWindows2000 + ¼°ÒÔºó°æ±¾ÓÐЧ¡£} + {.$define UseSwitchToThread} + +{----------------------------- µ÷ÊÔÑ¡Ïî -------------------------------} + +{¿ªÆô´ËÑ¡Ï²»»áΪFastMM4.pasµ¥Ôª²úÉúµ÷ÊÔ´úÂ룬Ҳ½«Í¬Ê±×èÖ¹µ÷ÊÔÆ÷½øÈëFastMM4.pasµ¥Ôª} +{.$define NoDebugInfo} + +{¿ªÆôÏÂÃæÑ¡Ï²»ÏÔʾÈκÎÐÅÏ¢£¬ÔÚ²»¿ÉÖÐÖ¹µÄ·þÎñÆ÷³ÌÐòÖбȽÏÓÐÓÃ} +{.$define NoMessageBoxes} + +{Èç¹ûҪʹÓÃWindows API OutputDebugString¹ý³ÌÀ´ÏÔʾµ÷ÊÔÐÅÏ¢Ç뿪ÆôÏÂÃæÑ¡Ïî} +{.$define UseOutputDebugString} + +{¿ªÆô´ËÑ¡Ïî»áʹÓûã±àÓïÑÔ°æ±¾µÄFastMM£¬Õâ±ÈPascal°æ±¾µÄÒª¿ì¡£½öÔÚµ÷ÊÔʱ¹Ø±Õ´ËÑ¡Ïî¡£ + ¿ªÆôCheckHeapForCorruption»á×Ô¶¯¹Ø±Õ´ËÉèÖÃ} +{$define ASMVersion} + +{FastMM×ܻᲶ׽µ½Á½´ÎÊͷŵÄͬһÄÚ´æÇøÓòµÄÔã¸â²Ù×÷£¬ËüÒ²¿ÉÒÔ¼ì²â¶ÑµÄ´íÎó£¨Í¨³£ÊÇÓÉ +ÓÚ³ÌÐòÔ½½ç¶ÁдÄڴ棩¡£ÕâЩ¼ì²âºÜºÄ·Ñʱ¼ä£¬ËùÒÔÕâ¸öÑ¡ÏîÓ¦½öµ±µ÷ÊÔʱʹÓá£Èç¹û´ËÑ¡Ïî +¿ªÆô£¬ASMVersion»á×Ô¶¯¹Ø±Õ} +{.$define CheckHeapForCorruption} + +{¿ªÆô´ËÑ¡Ïî»á¼ì²âÔÚFastMMÒÑжÔغó¶ÔÓû§¶ÔFastMMµÄÒýÓòÙ×÷¡£¿ªÆôºó£¬µ±FastMM±»Ð¶ÔØ£¬ + ½«²»»áÖØÐÂÆô¶¯ÏÈÇ°µÄÄÚ´æ¹ÜÀíÆ÷£¬¶øÊǼÙÏë´æÔÚÒ»¸öÄÚ´æ¹ÜÀíÆ÷£¬²¢ÇÒÒ»µ©ÓÐÄÚ´æ²Ù×÷±ã + Å׳ö´íÎó¡£Õâ»á²¶×½µ½µ±FastMMÒѱ»Ð¶Ôضø³ÌÐòÈÔ½øÐÐÄÚ´æ²Ù×÷µÄ´íÎó¡£} +{$define DetectMMOperationsAfterUninstall} + +{ÉèÖÃÒÔÏÂÑ¡ÏîÀ´¶ÔÄÚ´æй¶½øÐй㷺¼ì²â¡£ËùÓÐÄÚ´æ¿é¶¼»áÉèÖÿéÊ׺͸ú×ÙÆ÷À´Ð£Ñé¶ÑµÄÍê + ÕûÐÔ¡£ÊͷŵÄÄÚ´æ¿é£¨Ö¸Õ룩Ҳ»á±»Çå¿ÕÒÔ±£Ö¤ËüÃDz»»á±»ÔÙ´ÎʹÓá£ÕâһѡÏî»á´ó·ù¶È½µ + µÍÄÚ´æ²Ù×÷Ëٶȣ¬½öµ±µ÷ÊÔÒ»¸ö»áÔ½½ç¶ÁдÄÚ´æ»òÖظ´Ê¹ÓÃÒѱ»ÊͷŵÄÖ¸ÕëµÄ³ÌÐòʱ²ÅʹÓᣠ+ ¿ªÆô´ËÑ¡Ïî»á½ø¶ø×Ô¶¯¿ªÆôCheckHeapForCorruption²¢×Ô¶¯¹Ø±ÕASMVersion¡£Ìáʾ£ºµ±¿ªÆô + ´ËÑ¡Ïîʱ£¬³ÌÐòÐèҪʹÓÃFastMM_FullDebugMode.dllÎļþ¡£Èç¹û´ËÎļþ¶ªÊ§£¬³ÌÐò½«ÎÞ·¨Æô¶¯¡£} +{.$define FullDebugMode} + + {¿ªÆô´ËÑ¡ÏîÒÔ½øÐг¹µ×µÄÕ»×·×Ù£º¼ì²âËùÓÐÕ»ÌõÄ¿ÒÔÑ°ÕҺϷ¨µÄ·µ»ØµØÖ·¡£×¢ÒâÕâ±ÈʹÓà + Ö÷Õ»Ö¡µÄ·½·¨ÒªÂýºÜ¶à£¬µ«¸ü³¹µ×¡£½öµ±¿ªÆôFullDebugModeʱ´ËÑ¡ÏîÓÐЧ¡£} + {$define RawStackTraces} + + {¿ªÆô´ËÑ¡Ïî»á¼ì²â³ÌÐòÖжÔÒÑÏú»Ù¶ÔÏóµÄÒýÓá£×¢ÒâÕâ»áʹ¶ÔÒÑÊͷŶøÓÖÐ޸Ĺý£¨ÄÚÈݱ» + ¸²¸Ç£©µÄÄÚ´æ¿éµÄ¼ì²âÎÞ·¨½øÐУ¨Á½ÕßÎÞ·¨¹²´æ£©¡£½öµ±¿ªÆôFullDebugModeʱ´ËÑ¡ÏîÓÐЧ¡£} + {.$define CatchUseOfFreedInterfaces} + + {¿ªÆô´ËÑ¡ÏîÒԼǼËùÓеĴíÎóµ½Ò»¸öÓë³ÌÐòͬĿ¼µÄÎı¾ÎļþÖС£ÄÚ´æ·ÖÅä´íÎ󣨵±¿ªÆô + FullDebugMode£©½«»áÌí¼Óµ½Õâ¸öÈÕÖ¾Àï¡£Èç¹ûFullDebugMode¹Ø±Õ£¬´ËÑ¡ÏîÎÞЧ} + {$define LogErrorsToFile} + + {¿ªÆô´ËÑ¡Ï»á¼Ç¼ËùÓÐ鶵½Ò»¸öÓë³ÌÐòͬĿ¼µÄÎı¾ÎļþÖС£ÄÚ´æ鶱¨¸æ£¨µ±¿ªÆô + FullDebugMode£©½«»áÌí¼Óµ½Õâ¸öÈÕÖ¾Àï¡£Èç¹û"LogErrorsToFile"ºÍ"FullDebugMode"먦 + Æô´ËÑ¡ÏîÎÞЧ¡£×¢Òâͨ³£ËùÓÐ鶶¼»á±»¼Ç¼£¬ÉõÖÁÄÇЩAddExpectedMemoryLeaks±êʶµÄ + ¿ÉÄܵÄÄÚ´æй¶¡£ÄÇЩÓÉÖ¸ÕëÒýÆðµÄ¿ÉÄܵÄй¶¿ÉÄÜ»áÓÉÓÚ¿ªÆôHideExpectedLeaks- + RegisteredByPointer¶ø²»ÏÔʾ¡£} + {$define LogMemoryLeakDetailToFile} + + {³ÌÐòÆô¶¯Ê±É¾³ýÈÕÖ¾Îļþ¡£µ±LogErrorsToFile²»¿ªÆôʱÎÞЧ} + {.$define ClearLogFileOnStartup} + + {ÊÇ·ñ¶¯Ì¬Á´½ÓFASTMM_FullDebugMode.dll¡£Èç¹ûÕÒ²»µ½¸ÃDll£¬Õ»×·×Ù½«ÎÞ·¨½øÐС£×¢Òâ + µ±¹²ÏíÄÚ´æ¹ÜÀíÆ÷ʱÓÉÓÚDllжÔØ˳Ðò¸Ä±ä£¬¿ÉÄܻᷢÉú´íÎó¡£} + {.$define LoadDebugDLLDynamically} + + {.$define DoNotInstallIfDLLMissing} + {¿ªÆô´ËÑ¡Ïîºó£¬²¢ÇÒ¿ªÆôFullDebugModeºÍLoadDebugDLLDynamicallyʱ£¬Èç¹û + FastMM_FullDebugMode.dllÎļþ¶ªÊ§£¬ÄÇôFastMM½«²»»á¼ÓÔØ¡£} + + {FastMMͨ³£»áʹÓÃ×¶ËµÄ¿ÉÓõØÖ·À´·ÖÅä´óµÄÄÚ´æ¿é£¬¶øÔÚ×îµÍ¶ËµÄ¿ÉÓõØÖ·ÉÏ·ÖÅä + ÖС¢Ð¡ÄÚ´æ¿é£¨ÕâÔÚÒ»¶¨³Ì¶ÈÉϼõÉÙËéƬ£©¡£¿ªÆô´ËÑ¡Ïî»áʹÄÚ´æ·ÖÅä×ÜÓÅÏÈʹÓÃ× + ¶ËµÄ¿ÉÓõØÖ·¡£Èç¹û¹ý³ÌʹÓÃÁË´óÓÚ2GBµÄÄÚ´æ²¢ÇÒËã·¨´æÔÚÔã¸âµÄÖ¸Õë·ÖÅä £¬Õâ¸öÑ¡ + Ïî»á°ïÖú¾¡Ôç·¢ÏÖ´íÎó} + {$define AlwaysAllocateTopDown} + + {¿ªÆôºó½«²»»á¶ÔÄÚ´æת´¢½øÐÐÈÕÖ¾¼Ç¼£¬ÆäËü¼Ç¼Õý³£¡£} + {.$define DisableLoggingOfMemoryDumps} + + {FullDebugModeģʽÏ£¬µ±FreeMemµ÷ÓÃʧ°Üʱͨ³£»á·µ»ØÒ»¸ö¡°Ö¸Õë²Ù×÷ÎÞЧ¡±µÄ + ´íÎó¡£Èç¹û´ËʱÁíÒ»¸öÒì³£ÕýÔÚ±»´¦Àí£¨±ÈÈçÔÚ¡°try..finally¡±ÖУ©£¬ÄÇÔ­ÏȵÄÒì³£¾Í»á¶ªÊ§¡£ + ¿ªÆô´ËÑ¡Ïîºó£¬Èç¹û´ËʱÕýÓбðµÄÒì³£±»´¦Àí£¬ÄÇôFastMM½«ºöÂÔFreeMemÖз¢Éú´íÎó¡£} + {$define SuppressFreeMemErrorsInsideException} + +{--------------------------- ÄÚ´æ鶱¨¸æ -----------------------------} + +{¿ªÆô´ËÑ¡ÏîÒÔÔÊÐíÄÚ´æ鶱¨¸æ£¬ÓëÏÂÃæÁ½¸öÑ¡Ïî×éºÏʹÓá£} +{$define EnableMemoryLeakReporting} + + {¿ªÆôÏÂÃæÑ¡Ï²»»áÏÔʾºÍ¼Ç¼ÓÉÖ¸ÕëÀàÐ͵¼ÖµĿÉÄܵÄÄÚ´æй¶¡£ÓÉÀָࣨÕ룩ÒýÆð + µÄ¿ÉÄܵÄÄÚ´æй¶¾­³£²»Ã÷È·£¬ËùÒÔÕâЩ¿ÉÄܵÄй¶×ÜÊÇ»á¼Ç¼µ½ÈÕÖ¾£¨ÔÚFullDebugMode + ÓëLogMemoryLeakDetailToFile¿ªÆôʱ£©²¢ÇÒµ±Êµ¼Ê鶱ÈÆÚ´ýµÄ¶àʱһ¶¨»áÏÔʾ¡£} + {$define HideExpectedLeaksRegisteredByPointer} + + {¿ªÆôÏÂÃæÑ¡ÏîÒÔʵÏÖ½öÔÚDelphiÔÚÖ÷»úÉÏ´æÔÚʱ²Å±¨¸æÄÚ´æй¶¡£µ±"EnableMemoryLeakReporting" + ¹Ø±Õʱ´ËÑ¡ÏîÎÞЧ¡£} + {.$define RequireIDEPresenceForLeakReporting} + + {¿ªÆôÏÂÃæÑ¡ÏîÒÔʵÏÖ½öÔÚDelphiÖе÷ÊÔ³ÌÐòʱ²Å±¨¸æÄÚ´æй¶¡£µ±"EnableMemoryLeakReporting" + ¹Ø±Õʱ´ËÑ¡ÏîÎÞЧ¡£´ËÑ¡Ïî½öÔÚµ÷ÊÔEXE¹¤³ÌʱÓÐЧ£¬²»Ö§³ÖDll} + {$define RequireDebuggerPresenceForLeakReporting} + + {¿ªÆôÏÂÃæÑ¡ÏîÒÔʵÏÖ½öÔÚ±»±àÒëµ¥ÔªÖдæÔÚµ÷ÊÔָʾ·û£¨$D£©Ê±²Å½øÐÐй¶¼ì²â¡£µ± + "EnableMemoryLeakReporting"¹Ø±Õʱ´ËÑ¡ÏîÎÞЧ¡£} + {.$define RequireDebugInfoForLeakReporting} + + {¿ªÆô´ËÑ¡ÏîÒÔÊÖ¹¤¿ØÖÆÄÚ´æ鶱¨¸æ¡£µ±¿ªÆôʱ£¬ReportMemoryLeaksOnShutdown£¨³ÌÐò + ¹Ø±Õʱ±¨¸æÄÚ´æй¶£¬Ä¬ÈϹرգ©»á¸ÄΪѡÔñÊÇ·ñÉú³É±¨¸æ¡£¿ªÆôʱ£¬ÆäËüй¶¼ì²âÑ¡Ïî + Ò²±ØÐëÕýÈ·ÉèÖòÅÄܽøÐмì²â} + {.$define ManualLeakReportingControl} + + {¿ªÆôÏÂÃæÑ¡Ï²»ÏÔʾÄÚ´æй¶ÐÅÏ¢ÏÂÃæµÄÌáʾÓï} + {.$define HideMemoryLeakHintMessage} + +{-------------------------- Ö¸ÁÉèÖà ----------------------------} + +{¿ªÆôÏÂÃæÑ¡ÏîÒÔʹÓÃMMXÖ¸Á¡£¹Ø±Õ´ËÑ¡Ïî»áµ¼ÖÂÐÔÄÜÂÔ΢Ͻµ£¬µ«»áÓëAMD K5¡¢ + Pentium IµÈÔçÆÚ´¦ÀíÆ÷±£³Ö¼æÈÝ¡£Ä¿Ç°MMXÖ¸ÁîÖ»Ôڿɱä³ß´çµÄÄÚ´æÒƶ¯ÖÐʹÓã¬ËùÒÔÈç + ¹ûUseCustomVariableSizeMoveRoutines¹Ø±Õ£¬´ËÑ¡ÏîÎÞЧ¡£} +{.$define EnableMMX} + + {¿ªÆôÏÂÃæÑ¡ÏîÒÔÇ¿ÖÆʹÓÃMMXÖ¸Á£¬¶ø²»¹ÜCPUÊÇ·ñÖ§³Ö¡£Èç¹ûÕâһѡÏî±»¹Ø±Õ£¬ + ½«»áÊ×Ïȼì²éCPUÊÇ·ñÖ§³ÖMMXÖ¸Áî¡£µ±EnabledMMX¹Ø±ÕʱÎÞЧ¡£} + {$define ForceMMX} + +{----------------------- ¹²ÏíÄÚ´æ¹ÜÀíÆ÷ÉèÖà ------------------------} + +{ÔÊÐí¹²Í¬Ê¹ÓÃFastMM±àÒëµÄÖ÷³ÌÐòºÍDllÖ®¼ä¹²ÏíÄÚ´æ¹ÜÀíÆ÷¡£Äã¿ÉÒÔÏòDllÖеĺ¯Êý´«µÝ + ¶¯Ì¬Êý×éºÍ³¤×Ö·û´®¡£ÐèÒª±àÒëDllʱ¿ªÆôAttemptToUseSharedMM²Å¿ÉÒÔÕæÕýʵÏÖÄÚ´æ¹²Ïí¡£ + ×¢ÒâÈç¹ûÖ÷³ÌÐòÊǵ¥Ï̶߳øDllÊǶàÏ̵߳ģ¬Äã±ØÐëÔÚÖ÷³ÌÐòÀ￪ÆôIsMultiThread,·ñÔòÔÚ + Ï̳߳åͻʱ³ÌÐò»á±ÀÀ£¡£×¢Ò⾲̬Á´½ÓµÄDll»áÔÚÖ÷³ÌÐò֮ǰ³õʼ»¯£¬ËùÒÔÖ÷³ÌÐòʵ¼Ê»áÓë + Dll¹²ÏíÄÚ´æ¹ÜÀíÆ÷¡£ +} +{.$define ShareMM} + + {ÔÊÐíDllÖ®¼ä£¨»ò¾²Ì¬Á´½ÓDllʱÓëÖ÷³ÌÐòÖ®¼ä£©¹²ÏíÄÚ´æ¹ÜÀíÆ÷,ÒªÇó¹²Í¬Ê¹ÓÃFastMM±àÒë¡£ + ÔÚʹÓö¯Ì¬Á´½ÓµÄDllʱÐèҪעÒ⣬ÒòΪÈç¹ûDll±»Ð¶ÔضøÆäËüDllÈÔÔÚ¹²ÏíÄÚ´æ¹ÜÀíÆ÷£¬³Ì + Ðò½«»á±ÀÀ£¡£Õâ¸öÑ¡ÏîÖ»ÓëDll¿âÏà¹Ø¶øÇÒÐèÒªShareMMÓëAttemptToUseSharedMM¿ªÆô¡£×¢Òâ + Èç¹ûDllÊǾ²Ì¬Á´½ÓµÄ£¬ËüÃÇ»áÔÚÖ÷³ÌÐò֮ǰ³õʼ»¯£¬Êµ¼ÊÊÇÖ÷³ÌÐòÓëËüÃǹ²Ïí¹ÜÀíÆ÷¡£µ± + ShareMM¹Ø±Õʱ´ËÑ¡ÏîÎÞЧ} + {.$define ShareMMIfLibrary} + +{¿ªÆôÏÂÃæÑ¡Ï»á³¢ÊÔÔÚÖ÷³ÌÐòºÍÓëÖ®¹²Í¬±àÒëµÄDll£¨Ò²¿ªÆô´ËÑ¡Ï֮¼ä¹²ÏíÄÚ´æ¹ÜÀí + Æ÷¡£µ±¹²Ïíʱ£¬ÓÉʹÓù²ÏíÕß²úÉúµÄй¶½«²»»á×Ô¶¯Çå³ý¡£ÓÉÓÚ¾²Ì¬Á´½ÓµÄDllÊÇÔÚÖ÷³ÌÐò + ֮ǰ³õʼ»¯µÄ£¬ËùÒÔ¸ù¾ÝÇé¿öÉèÖù²ÏíÑ¡Ïî} +{.$define AttemptToUseSharedMM} + +{¿ªÆôÏÂÃæ±àÒëÑ¡ÏîÒÔ±£Ö¤ÄÚ´æ¹ÜÀíÆ÷µÄÏòºó¼æÈÝÐÔ¡£¶ÔDelphi2006ÓëDelphi2007ÓëÀÏ°æ±¾ +FastMMÓÐЧ} +{$define EnableBackwardCompatibleMMSharing} + +{-------------------------------- ×éºÏÉèÖà ------------------------------} + +{¿ªÆô´ËÑ¡Ï¼¤»îFullDebugMode¡¢InstallOnlyIfRunningInIDE¡¢LoadDebugDLLDynamically¡£ + Èç¹û³ÌÐòÕýÔÚDelphiÖнøÐе÷ÊÔÔËÐУ¬FastMM½«»á½øÐÐÍêÈ«µ÷ÊÔ£¨¿ªÆôFullDebugMode£©£¬·ñÔò + ½«Ê¹ÓÃĬÈÏÄÚ´æ¹ÜÀíÆ÷£¨Delphi2006°æ±¾ÒÔºóÊÇ먦ÆôFullDebugModeµÄFastMM£©¡£} +{.$define FullDebugModeInIDE} + +{¸ÃÑ¡Ïî´îÅäFullDebugMode¡¢LoadDebugDLLDynamicallyºÍDoNotInstallIfDLLMissingÒ»Æð + ʹÓ᣿ªÆôºóÈç¹ûÓÐFastMM_FullDebugMode.dllÎļþ²¢ÇÒ¿ªÆôÁËFullDebugModeÄÇô½«½øÈëÈ« + µ÷ÊÔģʽ¡£ÕâÑùÓÃÓÚ·¢²¼µÄexeºÍµ÷ÊÔµÄexe¿ÉÒÔÊÇͬһ¸öÎļþ£¬·¢²¼Ê±Ö»ÒªÈ¥µôFastMM_FullDebugMode.dll + Îļþ¾Í¿ÉÒÔÁË¡£} +{.$define FullDebugModeWhenDLLAvailable} + +{¿ìËÙÅäÖ÷¢²¼°æ±¾ºÍµ÷ÊÔ°æ±¾} +{$ifdef Release} + {·¢²¼°æ±¾ÇëÉèÖÃ} + {.$undef FullDebugMode} + {.$undef CheckHeapForCorruption} + {.$define ASMVersion} + {.$undef EnableMemoryLeakReporting} + {.$undef UseOutputDebugString} +{$else} + {µ÷ÊÔ°æ±¾ÇëÉèÖÃ} + {.$define FullDebugMode} + {.$define EnableMemoryLeakReporting} + {.$define UseOutputDebugString} +{$endif} + +{-------------------- borlndmm.dll ±àÒëÑ¡Ïî ---------------------} +{Èç¹ûÕýÔÚÖرàÒëborlandmm.dllÎļþ£¬Çë¸ù¾ÝÐèÒªÉèÖÃÒÔÏÂÑ¡Ïî} + +{µ±±àÒëborlandmm.dllʱÇ뿪Æô´ËÑ¡Ïî} +{.$define borlndmmdll} + +{Èç¹ûdll±»Delphi±¾ÉíʹÓÃÇ뿪Æô´ËÑ¡Ïî} +{.$define dllforide} + +{±àÒëµ÷ÊÔdllÎļþʱÇ뿪Æô´ËÑ¡Ïî} +{.$define debugdll} + +{ÒÔÏÂÄÚÈÝÇë²»Òª¸Ä¶¯} +{$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} + +{°ÑBCBµÄÏà¹ØÉèÖö¼·ÅÔÚÕâÀï¡£ÔÚ¡°Build with Dynamic RTL¡±Ñ¡ÏÆôµÄÇé¿öÏ£¬ +CB2006/CB2007¿ÉÒÔ±àÒëborlandmm.dllÎļþÒÔ×·×ÙÄÚ´æй¶¡£} +{------------------------------ רΪBCBÉèÖà ----------------------------} + +{Òª¿ªÆôΪBCB×¼±¸µÄ²¹¶¡£¬ÄãÐèÒªÔÚ"Project Options->Pascal/Delphi Compiler->Defines" + ÖÐÌí¼ÓBCBµÄ¶¨Òå¡££¨¸ÐлJiYuan XieʵÏÖÕâÒ»²¿·Ö£©} + +{$ifdef BCB} + {$ifdef CheckHeapForCorruption} + {$define PatchBCBTerminate} + {$else} + {$ifdef DetectMMOperationsAfterUninstall} + {$define PatchBCBTerminate} + {$else} + {$ifdef EnableMemoryLeakReporting} + {$define PatchBCBTerminate} + {$endif} + {$endif} + {$endif} + + {$ifdef PatchBCBTerminate} + {$define CheckCppObjectType} + {$undef CheckCppObjectTypeEnabled} + + {$ifdef CheckCppObjectType} + {$define CheckCppObjectTypeEnabled} + {$endif} + + {Èç¹û"CheckHeapForCorruption"ºÍ"EnableMemoryLeakReporting"¶¼Î´¿ªÆô£¬Çë¹Ø±Õ + "CheckCppObjectTypeEnabled"} + {$ifdef CheckHeapForCorruption} + {$else} + {$ifdef EnableMemoryLeakReporting} + {$else} + {$undef CheckCppObjectTypeEnabled} + {$endif} + {$endif} + {$endif} +{$endif} diff --git a/contrib/FastMM4-AVX/Translations/Czech/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Czech/FastMM4Messages.pas new file mode 100644 index 0000000..7a8807a --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Czech/FastMM4Messages.pas @@ -0,0 +1,138 @@ +{ + +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 +17.03.2007 rm Update to version FastMM v4.90 +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Neznámá tøída'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Výpis prvních 256 bytù pamìti, které zaèínají na adrese '; + {Block Error Messages} + BlockScanLogHeader = 'Alokované bloky byly zalogovány pomocí LogAllocatedBlocksToFile. Velikost je: '; + ErrorMsgHeader = 'FastMM detekoval chyby bìhem operace '; + GetMemMsg = 'GetMem'; + FreeMemMsg = 'FreeMem'; + ReallocMemMsg = 'ReallocMem'; + BlockCheckMsg = 'hledání prázdných blokù'; + OperationMsg = ' . '; + BlockHeaderCorruptedMsg = 'Hlavièka bloku byla poškozena. '; + BlockFooterCorruptedMsg = 'Patièka bloku byla poškozena. '; + FreeModifiedErrorMsg = 'FastMM detekoval modifikaci bloku po jeho uvolnìní. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Probìhl pokus o uvolnìní / realokaci již uvolnìného bloku.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Pøedchozí velikost bloku: '; + CurrentBlockSizeMsg = #13#10#13#10'Velikost bloku: '; + PreviousObjectClassMsg = #13#10#13#10'Blok byl již využit pro objekt typu: '; + CurrentObjectClassMsg = #13#10#13#10'Blok je aktuálnì využíván pro objekt typu: '; + PreviousAllocationGroupMsg = #13#10#13#10'Alokaèní skupina byla: '; // + PreviousAllocationNumberMsg = #13#10#13#10'Alokaèní èíslo bylo: '; + CurrentAllocationGroupMsg = #13#10#13#10'Alokaèní skupina je: '; + CurrentAllocationNumberMsg = #13#10#13#10'Alokaèní èíslo je: '; + BlockErrorMsgTitle = 'Detekována chyba práce s pamìtí'; + VirtualMethodErrorHeader = 'FastMM detekoval pokus o volání virtuální metody již uvolnìného objektu. Pro ukonèení této operace bude nyní vyhozena vyjímka (access violation).'; + InterfaceErrorHeader = 'FastMM detekoval pokus o pøístup k interface již uvolnìného objektu. Pro ukonèení této operace bude nyní vyhozena vyjímka (access violation).'; + BlockHeaderCorruptedNoHistoryMsg = ' Historie je nedostupná z dùvodu poškození hlavièky bloku.'; + FreedObjectClassMsg = #13#10#13#10'Typ uvolòovaného objektu: '; + VirtualMethodName = #13#10#13#10'Název virtuální metody: '; + VirtualMethodOffset = 'Offset +'; + VirtualMethodAddress = #13#10#13#10'Adresa virtuální metody: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'ID aktivního vlákna (thread ID) je 0x'; + CurrentStackTraceMsg = ' a stav na zásobníku volání (návratové adresy) je následující:'; + ThreadIDPrevAllocMsg = #13#10#13#10'Tento blok byl již jednou alokován vláknem 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'Tento blok byl alokován vláknem 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'Blok již byl jednou uvolnìn vláknem 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'Objekt byl alokován vláknem 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'Objekt byl opakovanì uvolnìn vláknem 0x'; + StackTraceMsg = ' v okamžiku, kdy zásobník volání obsahoval tyto návratové adresy:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 již byl nainstalován.'; + AlreadyInstalledTitle = 'Nainstalováno.'; + OtherMMInstalledMsg = 'FastMM4 nemohl být nainstalován, protože jiný memory ' + + 'manager (MM tøetí strany) již byl nainstalován.'#13#10'Pro použití 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ž nainstalován'; + MemoryAllocatedMsg = 'FastMM4 nemohl být nainstalován, protože jiný memory ' + + 'manager (standardní MM) již byl nainstalován.'#13#10'Pro použití FastMM4 ' + + 'zkontrolujte, zda je unita FastMM4.pas první unitou v sekci "uses" tohoto ' + + 'projektu (.dpr soubor).'#13#10#13#10 + + 'Pokud používáte nìjaký exception trapper (napø. MadExcept) nebo libovolný ' + + 'jiný nástroj, který modifikuje poøadí sekcí initialization, nakonfigurujte ' + + 'jej tak, aby unita FastMM4.pas byla inicializována pøed všemi ostatními unitami.'; + MemoryAllocatedTitle = 'Nelze nainstalovat FastMM4 - Pamì již byla alokována'; + {Leak checking messages} + LeakLogHeader = 'Blok pamìti zùstal neuvolnìn. Velikost(i): '; + LeakMessageHeader = 'Aplikace neuvolnila používanou pamì. '; + SmallLeakDetail = 'Bloky malé velikosti' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (vyjma chyb registrovaných pomocí ukazatelù)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Bloky støední a velké velikosti' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (vyjma chyb registrovaných pomocí ukazatelù)' +{$endif} + + ': '; + BytesMessage = ' bytù: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Poznámka: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Kontrola neuvolnìné pamìti je provádìna pouze pokud je prostøedí Delphi aktivní na tomtéž systému. ' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'Detailní informace o neuvolnìné pamìti jsou zapsány do textového souboru v adresáøi aplikace. ' + {$else} + + 'Povolením direktivy "LogMemoryLeakDetailToFile" lze do souboru logu zapsat detailní informace o neuvolnìné pamìti. ' + {$endif} + {$else} + + 'Pro získání logu s detailními informacemi o neuvolnìné pamìti je potøeba povolit direktivy "FullDebugMode" a "LogMemoryLeakDetailToFile". ' + {$endif} + + 'Vypnutím direktivy "EnableMemoryLeakReporting" lze deaktivovat tuto kontrolu neuvolnìné pamìti.'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Byla detekována neuvolnìná pamì (Memory Leak)'; +{$ifdef UseOutputDebugString} + FastMMInstallMsg = 'FastMM byl natažen.'; + FastMMInstallSharedMsg = 'Sdílení existující instance FastMM.'; + FastMMUninstallMsg = 'FastMM byl odinstalován.'; + FastMMUninstallSharedMsg = 'Zastaveno sdílení existující instance FastMM.'; +{$endif} +{$ifdef DetectMMOperationsAfterUninstall} + InvalidOperationTitle = 'Detekce MM volání po odinstalování FastMM.'; + InvalidGetMemMsg = 'FastMM detekoval volání GetMem, které probìhlo po odinstalaci FastMM.'; + InvalidFreeMemMsg = 'FastMM detekoval volání FreeMem, které probìhlo po odinstalaci FastMM.'; + InvalidReallocMemMsg = 'FastMM detekoval volání ReallocMem, které probìhlo po odinstalaci FastMM.'; + InvalidAllocMemMsg = 'FastMM detekoval volání ReallocMem, které probìhlo po odinstalaci FastMM.'; +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/Translations/English/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/English/FastMM4Messages.pas new file mode 100644 index 0000000..0c9485d --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/English/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unknown'; + {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. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: '; + CurrentBlockSizeMsg = #13#10#13#10'The block size is: '; + 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: '; + BlockErrorMsgTitle = 'Memory Error Detected'; + 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/French/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/French/FastMM4Messages.pas new file mode 100644 index 0000000..88d02e1 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/French/FastMM4Messages.pas @@ -0,0 +1,130 @@ +{ + +Fast Memory Manager: Messages + +French translation by Florent Ouchet. + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_Rapport.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Inconnu'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Contenu des 256 octets commençant à l''adresse '; + {Block Error Messages} + BlockScanLogHeader = 'Bloc alloué rapporté par LogAllocatedBlocksToFile. Sa taille est: '; + ErrorMsgHeader = 'FastMM a détecté une erreur pendant un '; + GetMemMsg = 'appel à GetMem'; + FreeMemMsg = 'appel à FreeMem'; + ReallocMemMsg = 'appel à ReallocMem'; + BlockCheckMsg = 'scan des blocs libres'; + OperationMsg = '. '; + BlockHeaderCorruptedMsg = 'L''en-tête du bloc a été corrompue. '; + BlockFooterCorruptedMsg = 'La fin du bloc a été corrompue. '; + FreeModifiedErrorMsg = 'FastMM a détecté qu''un bloc a été modifié après avoir été libéré. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Tentative d''appeler free ou reallocate pour un bloc déjà libéré.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'La taille précédente du bloc était: '; + CurrentBlockSizeMsg = #13#10#13#10'La taille du bloc est: '; + PreviousObjectClassMsg = #13#10#13#10'Le bloc était précédemment utilisé pour un objet de la classe: '; + CurrentObjectClassMsg = #13#10#13#10'Le bloc était actuellement utilisé pour un objet de la classe: '; + PreviousAllocationGroupMsg = #13#10#13#10'Le groupe d''allocations était: '; + PreviousAllocationNumberMsg = #13#10#13#10'Le nombre d''allocations était: '; + CurrentAllocationGroupMsg = #13#10#13#10'Le groupe d''allocation est: '; + CurrentAllocationNumberMsg = #13#10#13#10'Le nombre d''allocations est: '; + BlockErrorMsgTitle = 'Erreur mémoire détectée'; + VirtualMethodErrorHeader = 'FastMM a détecté une tentative d''appel d''une méthode virtuelle d''un objet libéré. Une violation d''accès va maintenant être levée dans le but d''annuler l''opération courante.'; + InterfaceErrorHeader = 'FastMM a détecté une tentative d''utilisation d''une interface d''un objet libéré. Une violation d''accès va maintenant être levée dans le but d''annuler l''opération courante.'; + BlockHeaderCorruptedNoHistoryMsg = ' La corruption de l''entête du bloc ne permet pas l''obtention de l''historique.'; + FreedObjectClassMsg = #13#10#13#10'Classe de l''objet libéré: '; + VirtualMethodName = #13#10#13#10'Méthode virtuelle: '; + VirtualMethodOffset = 'Décalage +'; + VirtualMethodAddress = #13#10#13#10'Adresse de la méthode virtuelle: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 est déjà installé.'; + AlreadyInstalledTitle = 'Déjà installé.'; + OtherMMInstalledMsg = 'FastMM4 ne peut pas être installé puisqu''un autre gestionnaire de mémoire s''est déjà installé.'#13#10 + + 'Pour utiliser FastMM4, FastMM4.pas doit être la toute première unité dans la section "uses" du fichier projet .dpr'; + OtherMMInstalledTitle = 'Impossible d''installer FastMM4 - un autre gestionnaire de mémoire est déjà installé'; + MemoryAllocatedMsg = 'FastMM4 ne peut pas être installé puisque des blocs de mémoire ont déjà été alloué par le gestionnaire de mémoire par défaut.'#13#10 + + 'FastMM4.pas DOIT être la première unité dans la section "uses" du fichier projet .dpr; dans le cas contraire, des blocs de mémoire '#1310 + + 'peuvent être alloués avant que FastMM4 ne prenne le contrôle, si vous utilisez un gestionnaire d''exception comme MadExcept '#1310 + + '(ou tout autre outil qui modifie l''ordre d''initialisation des unités). Veuillez modifier sur la page de configuration de cet outil'#1310 + + 'l''ordre d''initialisation des unités pour que FastMM4.pas soit initialisée avant tout autre unité'; + MemoryAllocatedTitle = 'Impossible d''installer FastMM4 - des blocs de mémoire ont déjà été alloués'; + {Leak checking messages} + LeakLogHeader = 'Une fuite mémoire a été détectée. Sa taille est: '; + LeakMessageHeader = 'Cette application a fuit de la mémoire. '; + SmallLeakDetail = 'Les fuites de petits blocs sont' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluant toutes les fuites masquées)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Les tailles des blocs moyens et grands sont' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluant toutes les fuites masquées)' +{$endif} + + ': '; + BytesMessage = ' octets: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Conseil: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Cette vérification des fuites mémoire n''est effectué que si Delphi est actuellement exécuté sur la même machine. ' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'Les détails des fuites de mémoire sont rapportés dans un fichier texte dans le même répertoire que l''application. ' + {$else} + + 'Activez l''option "LogMemoryLeakDetailToFile" pour obtenir un fichier rapportant les détails des fuites de mémoire. ' + {$endif} + {$else} + + 'Pour obtenir un fichier rapport contenant les détails des fuites de mémoire, activez les options de compilation "FullDebugMode" et "LogMemoryLeakDetailToFile". ' + {$endif} + + 'Pour désactiver cette vérification des fuites mémoires, désactivez l''option de compilation "EnableMemoryLeakReporting".'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Fuite mémoire détectée'; +{$ifdef UseOutputDebugString} + FastMMInstallMsg = 'FastMM a été installé.'; + FastMMInstallSharedMsg = 'Partageant un exemplaire existant de FastMM.'; + FastMMUninstallMsg = 'FastMM a été désinstallé.'; + FastMMUninstallSharedMsg = 'Fin du partage avec un exemplaire existant de FastMM.'; +{$endif} +{$ifdef DetectMMOperationsAfterUninstall} + InvalidOperationTitle = 'Operation MM après la désinstallation.'; + InvalidGetMemMsg = 'FastMM a détecté un appel à GetMem après que FastMM ait été désinstallé.'; + InvalidFreeMemMsg = 'FastMM a détecté un appel à FreeMem après que FastMM ait été désinstallé.'; + InvalidReallocMemMsg = 'FastMM a détecté un appel à ReallocMem après que FastMM ait été désinstallé.'; + InvalidAllocMemMsg = 'FastMM a détecté un appel à AllocMem après que FastMM ait été désinstallé.'; +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/Translations/German/by Thomas Speck/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/German/by Thomas Speck/FastMM4Messages.pas new file mode 100644 index 0000000..faa4d3c --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/German/by Thomas Speck/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unbekannt'; + {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 während 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 verändert wurde. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Es wurde versucht, einen unbelegten Block freizugeben bzw. zu belegen.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Die vorherige Blockgröße war: '; + CurrentBlockSizeMsg = #13#10#13#10'Die Blockgröße ist: '; + PreviousObjectClassMsg = #13#10#13#10'Der Block wurde vorher für eine Objektklasse benutzt: '; + CurrentObjectClassMsg = #13#10#13#10'Der Block wird momentan für 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: '; + BlockErrorMsgTitle = 'Speicherfehler entdeckt'; + 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 = ' Unglücklicherweise wurde der Block-Beginn beschädigt, so daß keine Historie verfügbar 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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 abfängt ' + + 'z.B. MadExcept (oder ein anderes Tool, das die Reihenfolge der Unit Initialisierung ' + + 'verändert),'#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 Größe ist: '; + LeakMessageHeader = 'Diese Anwendung hat Speicher verloren. '; + SmallLeakDetail = 'Die Größen von kleinen Speicherblöcken, die verlorengegangen sind, betragen' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (ausgenommen erwartete Speicherlecks, die durch Zeiger registriert wurden)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Die Größen von mittleren und großen Speicherblöcken, die verlorengegangen sind, betragen' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (ausgenommen erwartete Speicherlecks, die durch Zeiger registriert wurden)' +{$endif} + + ': '; + BytesMessage = ' Bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Notiz: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Diese Überprüfung auf Speicherlecks wird nur durchgeführt, 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 enthält. ' + {$endif} + {$else} + + 'Um eine Log-Datei zu erhalten, die Details zu Speicherlecks enthält, aktivieren Sie "FullDebugMode" und "LogMemoryLeakDetailToFile" in der Options-Datei. ' + {$endif} + + 'Um diese Speicherleck-Überprüfung 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/contrib/FastMM4-AVX/Translations/German/by Uwe Queisser/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/German/by Uwe Queisser/FastMM4Messages.pas new file mode 100644 index 0000000..0dfe2fc --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/German/by Uwe Queisser/FastMM4Messages.pas @@ -0,0 +1,131 @@ +{Fast Memory Manager: Meldungen + +Deutsche Übersetzung von Uwe Queisser [uweq] + +} +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {Der Name der Debug-Info-DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.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'; + {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, während ein'; + GetMemMsg = ' GetMem'; + FreeMemMsg = ' FreeMem'; + ReallocMemMsg = ' ReallocMem'; + BlockCheckMsg = 'er freier SpeicherBlocküberprüfung'; + 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. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Es wurde ein Versuch unternommen, einen freigegebenen Speicherblock freizugeben / wiederzuverwenden.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Die vorherige Speicherblockgröße war: '; + CurrentBlockSizeMsg = #13#10#13#10'Die Speicherblockgröße ist: '; + PreviousObjectClassMsg = #13#10#13#10'Der Speicherpuffer wurde zuvor für ein Objekt der folgenden Klasse verwendet: '; + CurrentObjectClassMsg = #13#10#13#10'Der Speicherpuffer wird gegenwärtig für 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: '; + BlockErrorMsgTitle = 'Speicherfehler gefunden'; + 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 verfügbar 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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 ' + + 'möchten, 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 Größe : '; + LeakMessageHeader = 'Diese Anwendung hat Speicher-Lecks. '; + SmallLeakDetail = 'Die kleineren Speicher-Lecks sind' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (ausschließlich von Zeigern registrierte Lecks)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Die größeren Speicher-Lecks sind' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (ausschließlich von Zeiger registrierte Lecks)' +{$endif} + + ': '; + BytesMessage = ' bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Hinweis: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Diese Speicherleckprüfung wird nur ausgeführt, wenn Delphi gegenwärtig auf demselben Computer läuft. ' + {$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 enthält, aktivieren Sie die "{$ FullDebugMode}" und "{$ LogMemoryLeakDetailToFile}" Definitionen. ' + {$endif} + + 'Um die Speicherleckprüfung 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/contrib/FastMM4-AVX/Translations/Indonesian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Indonesian/FastMM4Messages.pas new file mode 100644 index 0000000..0e2d62f --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Indonesian/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +Fast Memory Manager: Messages + +Indonesian translation by Zaenal Mutaqin. + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_Laporan_ManajerMemori.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Tidak dikenal'; + {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. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Percobaan dilakukan untuk membebaskan/realokasi blok yang tidak dialokasikan'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Besar blok sebelumnya adalah: '; + CurrentBlockSizeMsg = #13#10#13#10'Besar blok adalah: '; + 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: '; + BlockErrorMsgTitle = 'Kesalahan Memori Terdeteksi'; + 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/Italian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Italian/FastMM4Messages.pas new file mode 100644 index 0000000..df57ce2 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Italian/FastMM4Messages.pas @@ -0,0 +1,136 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Sconosciuta'; + {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. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Tentativo di disallocare/reallocare un blocco non allocato.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'La dimensione precedente del blocco era: '; + CurrentBlockSizeMsg = #13#10#13#10'La dimensione del blocco è: '; + 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 è: '; + BlockErrorMsgTitle = 'Rilevato Errore di Memoria'; + 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: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/Polish/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Polish/FastMM4Messages.pas new file mode 100644 index 0000000..607eff2 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Polish/FastMM4Messages.pas @@ -0,0 +1,134 @@ +{ + +Fast Memory Manager: Messages + +Polish translation by Artur RedŸko (arturr@opegieka.pl). + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_raport.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Nieznany'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Aktualny zrzut pamiêci 256 bajtów zaczynaj¹cy siê od adresu '; + {Block Error Messages} + BlockScanLogHeader = 'Zaalokowany blok zapisany przez LogAllocatedBlocksToFile. Rozmiar : '; + ErrorMsgHeader = 'FastMM wykry³ b³¹d podczas operacji '; + GetMemMsg = 'GetMem'; + FreeMemMsg = 'FreeMem'; + ReallocMemMsg = 'ReallocMem'; + BlockCheckMsg = 'skanowania wolnego bloku'; + OperationMsg = '. '; + BlockHeaderCorruptedMsg = 'Nag³ówek bloku jest uszkodzony. '; + BlockFooterCorruptedMsg = 'Stopka bloku jest uszkodzona. '; + FreeModifiedErrorMsg = 'FastMM wykry³ ¿e blok zosta³ zmodyfikowany po tym jak zosta³ zwolniony. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Wykryto próbê zwolnienia/realokacji niezaalokowanego bloku.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Poprzedni rozmiar bloku by³: '; + CurrentBlockSizeMsg = #13#10#13#10'Rozmiar bloku jest: '; + PreviousObjectClassMsg = #13#10#13#10'Blok zosta³ poprzednio u¿yty w obiekcie klasy: '; + CurrentObjectClassMsg = #13#10#13#10'Blok jest aktualnie u¿ywany w obiekcie klasy: '; + PreviousAllocationGroupMsg = #13#10#13#10'By³a grupa alokacji : '; + PreviousAllocationNumberMsg = #13#10#13#10'By³a iloœæ alokacji : '; + CurrentAllocationGroupMsg = #13#10#13#10'Jest grupa alokacji : '; + CurrentAllocationNumberMsg = #13#10#13#10'Jest iloœæ alokacji : '; + BlockErrorMsgTitle = 'Wykryto b³¹d pamiêci'; + VirtualMethodErrorHeader = 'FastMM wykry³ próbê u¿ycia wirtualnej metody zwolnionego obiektu. Zostanie wygenerowany teraz wyj¹tek w celu przerwania aktualnej operacji.'; + InterfaceErrorHeader = 'FastMM wykry³ próbê u¿ycia interfejsu zwolnionego obiektu. Zostanie wygenerowany teraz wyj¹tek w celu przerwania aktualnej operacji.'; + BlockHeaderCorruptedNoHistoryMsg = ' Niestety nag³ówek bloku zosta³ uszkodzony wiêc historia nie jest dostêpna.'; + FreedObjectClassMsg = #13#10#13#10'Klasa zwolnionego obiektu: '; + VirtualMethodName = #13#10#13#10'Metoda wirtualna: '; + VirtualMethodOffset = 'przesuniêcie +'; + VirtualMethodAddress = #13#10#13#10'Adres metody wirtualnej: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 jest ju¿ zainstalowany.'; + AlreadyInstalledTitle = 'Ju¿ zainstalowany.'; + OtherMMInstalledMsg = 'FastMM4 nie mo¿e byæ zainstalowany poniewa¿ inny mened¿er pamiêci ' + + 'zosta³ ju¿ zainstalowany.'#13#10'Jeœli chcesz u¿yæ FastMM4, ' + + 'zapewniaj¹c aby modu³ FastMM4.pas by³ zainicjowany jako pierwszy modu³ w twoim projekcie.'; + OtherMMInstalledTitle = 'Nie mo¿na zainstalowaæ FastMM4 - inny mened¿er pamiêci jest ju¿ zainstalowany'; + MemoryAllocatedMsg = 'FastMM4 nie mo¿e byæ zainstalowany poniewa¿ pamiêæ zosta³a ' + + 'juz zaalokowana przez domyœlny mened¿er pamiêci.'#13#10'FastMM4.pas MUSI ' + + 'byæ pierwszym modu³em w twoim projekcie, w przeciwnym wypadku pamiêæ mo¿e ' + + 'byæ zaalokowana'#13#10'przez domyœlny mened¿er pamiêci zanim FastMM4 ' + + 'przejmie kontrolê.'#13#10#13#10'Jeœli u¿ywasz aplikacji do przechwytywania wyj¹tków ' + + 'takich jak MadExcept,'#13#10'zmieñ jego konfiguracjê zapewniaj¹c aby modu³ ' + + 'FastMM4.pas by³ zainicjowany jako pierwszy modu³.'; + MemoryAllocatedTitle = 'Nie mo¿na zainstalowaæ FastMM4 - pamiêæ zosta³a ju¿ zaalokowana.' + + 'FastMM4.pas jest inicjowany jako pierwszy modu³.'; + {Leak checking messages} + LeakLogHeader = 'Wyciek³ blok pamiêci. Rozmiar wynosi: '; + LeakMessageHeader = 'Aplikacja wykry³a wycieki pamiêci. '; + SmallLeakDetail = 'Ma³e bloki wycieków s¹' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (wy³¹czaj¹c oczekiwane wycieki zarejestrowane przez wskaŸnik)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Rozmiary œrednich i du¿ych wycieków wynosz¹' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (wy³¹czaj¹c oczekiwane wycieki zarejestrowane przez wskaŸnik)' +{$endif} + + ': '; + BytesMessage = ' bajtów: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Uwaga: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Sprawdzenie wycieków pamiêci wystêpuje tylko gdy Delphi jest uruchomione na tym samych komputerze. ' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'Szczegó³y wycieków s¹ rejestrowane w pliku tekstowym w tym samym katalogu co aplikacja. ' + {$else} + + 'W³¹cz "LogMemoryLeakDetailToFile" aby uzyskaæ szczegó³owy plik z wyciekami pamiêci. ' + {$endif} + {$else} + + 'Aby uzyskaæ plik ze szczegó³ami wycieków pamiêci, w³¹cz definicje warunkowe "FullDebugMode" i "LogMemoryLeakDetailToFile". ' + {$endif} + + 'Aby wy³¹czyæ raportowanie wycieków, wy³¹cz "EnableMemoryLeakReporting".'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Wykryto wyciek pamiêci'; +{$ifdef UseOutputDebugString} + FastMMInstallMsg = 'FastMM zosta³ zainstalowany.'; + FastMMInstallSharedMsg = 'Rozpoczêcie wspó³dzielenia istniej¹cej instancji FastMM.'; + FastMMUninstallMsg = 'FastMM zosta³ odinstalowany.'; + FastMMUninstallSharedMsg = 'Zakoñczenie wspó³dzielenia istniej¹cej instancji FastMM.'; +{$endif} +{$ifdef DetectMMOperationsAfterUninstall} + InvalidOperationTitle = 'Operacja MM po deinstalacji.'; + InvalidGetMemMsg = 'FastMM wykry³ wywo³anie GetMem po tym jak FastMM zosta³ odinstalowany.'; + InvalidFreeMemMsg = 'FastMM wykry³ wywo³anie FreeMem po tym jak FastMM zosta³ odinstalowany.'; + InvalidReallocMemMsg = 'FastMM wykry³ wywo³anie ReallocMem po tym jak FastMM zosta³ odinstalowany.'; + InvalidAllocMemMsg = 'FastMM wykry³ wywo³anie AllocMem po tym jak FastMM zosta³ odinstalowany.'; +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/Translations/Portuguese (Brazil)/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Portuguese (Brazil)/FastMM4Messages.pas new file mode 100644 index 0000000..e96ec8a --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Portuguese (Brazil)/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventosLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Desconhecida'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Dump de memória atual de 256 bytes iniciando no endereço '; + {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 = ' operação. '; + BlockHeaderCorruptedMsg = 'O cabeçalho do bloco foi corrompido. '; + BlockFooterCorruptedMsg = 'O rodapé do bloco foi corrompido. '; + FreeModifiedErrorMsg = 'FastMM detectou que um bloco foi modificado após ter sido liberado. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Uma tentativa foi feita para liberar/realocar um bloco não alocado.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'O tamanho anterior do bloco era: '; + CurrentBlockSizeMsg = #13#10#13#10'O tamanho do bloco é: '; + 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 alocação era: '; + PreviousAllocationNumberMsg = #13#10#13#10'O número da alocação era: '; + CurrentAllocationGroupMsg = #13#10#13#10'O grupo de alocação é: '; + CurrentAllocationNumberMsg = #13#10#13#10'O número da alocação é: '; + BlockErrorMsgTitle = 'Erro de memória detectado'; + VirtualMethodErrorHeader = 'FastMM detectou uma tentativa de chamada a um método virtual de um objeto liberado. Uma violação de acesso será disparada para abortar a operação corrente.'; + InterfaceErrorHeader = 'FastMM detectou uma tentativa de uso de uma interface de um objeto liberado. Uma violação de acesso será disparada para abortar a operação corrente.'; + BlockHeaderCorruptedNoHistoryMsg = ' Infelizmente o cabeçalho do bloco foi corrompido e a história não está disponível.'; + FreedObjectClassMsg = #13#10#13#10'Classe do objeto liberado: '; + VirtualMethodName = #13#10#13#10'Método virtual: '; + VirtualMethodOffset = 'Offset +'; + VirtualMethodAddress = #13#10#13#10'Endereço do método virtual: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'O ID da thread atual é 0x'; + CurrentStackTraceMsg = ', e a análise da pilha interna (endereços de retorno) que levaram a este erro é:'; + ThreadIDPrevAllocMsg = #13#10#13#10'Este bloco foi criado anteriormente pela thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'Este bloco foi alocado pela thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'Este bloco foi liberado anteriormente pela thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'O objeto foi alocado pela thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'O objeto foi liberado posteriormente pela thread 0x'; + StackTraceMsg = ', e a análise da pilha interna (endereços de retorno) no momento era:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 já foi instalado.'; + AlreadyInstalledTitle = 'Já foi instalado.'; + OtherMMInstalledMsg = 'FastMM4 não pode ser instalado já que outro gerenciador externo ' + + 'de memória já foi instalado.'#13#10'Se você quer usar o FastMM4, ' + + 'tenha certeza que a unit FastMM4.pas seja a primeira na seção "uses"' + + #13#10'do arquivo .dpr do seu projeto.'; + OtherMMInstalledTitle = 'Impossível instalar FastMM4 - Outro gerenciador de memória já está instalado'; + MemoryAllocatedMsg = 'O FastMM4 não pode ser instalado já que a memória já foi ' + + 'alocada através do gerenciador de memória padrão.'#13#10'FastMM4.pas DEVE ' + + 'ser a primeira unit no arquivo .dpr do seu projeto, caso contrário a memória pode ' + + 'ser alocada'#13#10'através do gerenciador de memória padrão antes que o FastMM ' + + 'ganhe o controle. '#13#10#13#10'Se você estiver usando um interceptador de exceções ' + + 'como MadExcept (ou qualquer outra ferramenta que modifica a ordem de inicialização da ' + + 'unit),'#13#10'vá para sua página de configuração e tenha certeza que a unit ' + + 'FastMM4.pas seja inicializada antes de qualquer outra unit.'; + MemoryAllocatedTitle = 'Impossível instalar FastMM4 - A memória já foi alocada'; + {Leak checking messages} + LeakLogHeader = 'Um bloco de memória vazou. O tamanho é: '; + LeakMessageHeader = 'Essa aplicação teve vazamentos de memória. '; + SmallLeakDetail = 'Os vazamentos dos blocos pequenos são' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluindo os vazamentos esperados registrados por ponteiro)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'O tamanho dos vazamentos dos blocos médios e grandes são' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluindo os vazamentos esperados registrados por ponteiro)' +{$endif} + + ': '; + BytesMessage = ' bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Nota: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Essa checagem de vazamento de memória somente é feita se o Delphi está rodando atualmente no mesmo computador. ' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'O detalhe do vazamento de memória está logado em um arquivo texto na mesma pasta que essa aplicação. ' + {$else} + + 'Habilite o DEFINE "LogMemoryLeakDetailToFile" para obter um arquivo de log contendo detalhes dos vazamentos de memória. ' + {$endif} + {$else} + + 'Para obter um arquivo de log contendo detalhes dos vazamentos de memória, habilite os DEFINES "FullDebugMode" e "LogMemoryLeakDetailToFile". ' + {$endif} + + 'Para desabilitar essa checagem de vazamento de memória, desabilite o DEFINE "EnableMemoryLeakReporting".'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Vazamento de memória 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 = 'Operação no Gerenciador de Memória após desinstalação.'; + 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/contrib/FastMM4-AVX/Translations/Portuguese/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Portuguese/FastMM4Messages.pas new file mode 100644 index 0000000..e53d8b0 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Portuguese/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +Fast Memory Manager: Messages + +Portuguese translation by Carlos Mação (Carlos.Macao@gmail.com). + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventosLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Desconhecida'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'O Dump de memória actual de 256 bytes tem inicio no endereço '; + {Block Error Messages} + BlockScanLogHeader = 'Bloco atribuído registado por LogAllocatedBlocksToFile. O Tamanho é: '; + ErrorMsgHeader = 'FastMM detectou um erro durante '; + GetMemMsg = 'GetMem'; + FreeMemMsg = 'FreeMem'; + ReallocMemMsg = 'ReallocMem'; + BlockCheckMsg = 'procura de bloco livre'; + OperationMsg = ' operação. '; + BlockHeaderCorruptedMsg = 'O cabeçalho do bloco foi corrompido. '; + BlockFooterCorruptedMsg = 'O rodapé do bloco foi corrompido. '; + FreeModifiedErrorMsg = 'FastMM detectou que um bloco de memória foi modificado após ter sido libertado. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Foi feita uma tentativa para libertar/atribuir um bloco não atribuido.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'O tamanho anterior do bloco era: '; + CurrentBlockSizeMsg = #13#10#13#10'O tamanho do bloco é: '; + 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 atribuição era: '; + PreviousAllocationNumberMsg = #13#10#13#10'O número de atribuição era: '; + CurrentAllocationGroupMsg = #13#10#13#10'O grupo de atribuição é: '; + CurrentAllocationNumberMsg = #13#10#13#10'O número de atribuição era: '; + BlockErrorMsgTitle = 'Erro de memória detectado'; + VirtualMethodErrorHeader = 'FastMM detectou uma tentativa de chamada a um método virtual de um objecto libertado. Uma violação de acesso será iniciada para abortar a operação corrente.'; + InterfaceErrorHeader = 'FastMM detectou uma tentativa de uso de uma interface de um objecto libertado. Uma violação de acesso será iniciada para abortar a operação corrente.'; + BlockHeaderCorruptedNoHistoryMsg = ' Infelizmente o cabeçalho do bloco foi corrompido e o histórico não está disponível.'; + FreedObjectClassMsg = #13#10#13#10'Classe do objecto libertado: '; + VirtualMethodName = #13#10#13#10'Método virtual: '; + VirtualMethodOffset = 'Deslocamento +'; + VirtualMethodAddress = #13#10#13#10'Endereço do método virtual: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'O ID da thread actual é 0x'; + CurrentStackTraceMsg = ', e a análise da pilha interna (endereços de retorno) que conduziram a este erro é:'; + ThreadIDPrevAllocMsg = #13#10#13#10'Este bloco foi préviamente criado pela thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'Este bloco foi criado pela thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'Este bloco foi préviamente libertado pela thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'O objecto foi criado pela thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'O objecto foi posteriormente libertado pela thread 0x'; + StackTraceMsg = ', e a análise da pilha interna (endereços de retorno) nesse momento era:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 já se encontra instalado.'; + AlreadyInstalledTitle = 'Já se encontra instalado.'; + OtherMMInstalledMsg = 'FastMM4 não pôde ser instalado já que outro gestor ' + + 'de memória externo já foi instalado.'#13#10'Se você quer usar o FastMM4, ' + + 'garanta que a unit FastMM4.pas é a primeira na secção "uses"' + + #13#10'do ficheiro .dpr do seu projecto.'; + OtherMMInstalledTitle = 'Impossível instalar FastMM4 - Outro gestor de memória já se encontra instalado'; + MemoryAllocatedMsg = 'O FastMM4 não pode ser instalado já que a memória já foi ' + + 'atribuida através do gestor de memória padrão.'#13#10'FastMM4.pas DEVE ' + + 'ser a primeira unit no arquivo .dpr do seu projecto, caso contrário a memória pode ' + + 'ser atribuida'#13#10'através do gestor de memória padrão antes que o FastMM ' + + 'obtenha o controle. '#13#10#13#10'Se você estiver usando um interceptador de excepções ' + + 'como MadExcept (ou qualquer outra ferramenta que modifica a ordem de inicialização da ' + + 'unit),'#13#10'vá para sua página de configuração e assegure-se que a unit ' + + 'FastMM4.pas ''é inicializada antes de qualquer outra unit.'; + MemoryAllocatedTitle = 'Impossível instalar FastMM4 - A memória já foi atribuida'; + {Leak checking messages} + LeakLogHeader = 'Um bloco de memória não foi libertado. O tamanho é: '; + LeakMessageHeader = 'Esta aplicação teve fugas de memória. '; + SmallLeakDetail = 'As fugas dos blocos pequenos são' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluindo as fugas esperadas, registadas por ponteiro)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'O tamanho das fugas dos blocos médios e grandes é' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluindo as fugas esperadas registadas por ponteiro)' +{$endif} + + ': '; + BytesMessage = ' bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Nota: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Os testes de fugas de memória só serão efectuados se o Delphi estiver activo no mesmo computador. ' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'O detalhe da fuga de memória foi registado num ficheiro de texto na mesma pasta desta aplicação. ' + {$else} + + 'Active o DEFINE "LogMemoryLeakDetailToFile" para obter um ficheiro de registos contendo detalhes das fugas de memória. ' + {$endif} + {$else} + + 'Para obter um ficheiro de registo contendo detalhes das fugas de memória, active os DEFINES "FullDebugMode" e "LogMemoryLeakDetailToFile". ' + {$endif} + + 'Para activar a detecção de fugas de memória, active o DEFINE "EnableMemoryLeakReporting".'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Fuga de memória detectada'; +{$ifdef UseOutputDebugString} + FastMMInstallMsg = 'FastMM foi instalado.'; + FastMMInstallSharedMsg = 'Partilhando uma instância já existente do FastMM.'; + FastMMUninstallMsg = 'FastMM foi removido.'; + FastMMUninstallSharedMsg = 'Parando a partilha duma instância existente do FastMM.'; +{$endif} +{$ifdef DetectMMOperationsAfterUninstall} + InvalidOperationTitle = 'Operação com o gestor de Memória após a sua remoção.'; + InvalidGetMemMsg = 'FastMM detectou uma chamada a GetMem após a remoção do FastMM.'; + InvalidFreeMemMsg = 'FastMM detectou uma chamada a FreeMem após a remoção do FastMM.'; + InvalidReallocMemMsg = 'FastMM detectou uma chamada a ReallocMem após a remoção do FastMM.'; + InvalidAllocMemMsg = 'FastMM detectou uma chamada a ReallocMem após a remoção do FastMM.'; +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/Translations/Romanian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Romanian/FastMM4Messages.pas new file mode 100644 index 0000000..8283b80 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Romanian/FastMM4Messages.pas @@ -0,0 +1,143 @@ +{ + +Fast Memory Manager: Messages + +Romanian translation by Ionut Muntean + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Necunoscut'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Dump curent 256 bytes incepand cu adresa pointerului: '; + {Block Error Messages} + BlockScanLogHeader = 'Bloc memorie alocat de LogAllocatedBlocksToFile. Dimensiunea este de: '; + ErrorMsgHeader = 'FastMM a detectat o eroare in '; + GetMemMsg = 'GetMem'; + FreeMemMsg = 'FreeMem'; + ReallocMemMsg = 'ReallocMem'; + BlockCheckMsg = 'scanarea blocurilor libere'; + OperationMsg = ' operatie. '; + BlockHeaderCorruptedMsg = 'Inceputul (header) de bloc este corupt. '; + BlockFooterCorruptedMsg = 'Sfarsitul (footer) de bloc este corupt. '; + FreeModifiedErrorMsg = 'FastMM a detectat ca un bloc a fost modificat dupa eliberare. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'A fost detectata o incercare de eliberare/realocare a unui bloc nealocat.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Dimensiunea precedenta a blocului a fost de: '; + CurrentBlockSizeMsg = #13#10#13#10'Dimensiunea blocului este de: '; + PreviousObjectClassMsg = #13#10#13#10'Blocul de memorie a fost folosit inainte pentru un obiect de clasa: '; + CurrentObjectClassMsg = #13#10#13#10'Blocul de memorie este folosit pentru un obiect de clasa: '; + PreviousAllocationGroupMsg = #13#10#13#10'Grupul de alocare a fost: '; + PreviousAllocationNumberMsg = #13#10#13#10': Numarul de alocare a fost'; + CurrentAllocationGroupMsg = #13#10#13#10'Grupul de alocare este: '; + CurrentAllocationNumberMsg = #13#10#13#10'Numarul de alocare este: '; + BlockErrorMsgTitle = 'A fost detectata o eroare de memorie'; + VirtualMethodErrorHeader = 'FastMM a detectat o incercare de apel a unei proceduri virtuale dupa ce obiectul a fost eliberat. O exceptie de tip "Access violation" va fi alocata pentru a stopa operatia curenta.'; + InterfaceErrorHeader = 'FastMM a detectat o incercare de utilizare a unei interfete a unui obiect deja eliberat. O exceptie de tip "Access violation" va fi alocata pentru a stopa operatia curenta.'; + BlockHeaderCorruptedNoHistoryMsg = ' Din pacate, inceputul (headerul) de bloc este atat de corupt incat nici un istoric pentru acesta nu poate fi stabilit.'; + FreedObjectClassMsg = #13#10#13#10'Clasa obiectului eliberat: '; + VirtualMethodName = #13#10#13#10'Metoda virtuala: '; + VirtualMethodOffset = 'Offset +'; + VirtualMethodAddress = #13#10#13#10'Adresa metoda virtuala: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {Installation Messages} + AlreadyInstalledMsg = 'FastMM4 este deja instalat.'; + AlreadyInstalledTitle = 'Deja instalat.'; + OtherMMInstalledMsg = 'FastMM4 nu poate fi instalat din cauza unui alt Memory Manager ' + + 'care este deja instalat in contextul curent.'#13#10'Daca doriti utilizarea FastMM4, ' + + 'asigurati-va ca FastMM4.pas este primul unit inclus in clauza "uses"' + + 'din fisierul .dpr a proiectului Dvs..'; + OtherMMInstalledTitle = 'Nu pot instala FastMM4 - Un alt Memory Manager este deja instalat.'; + + +//****************************************************************************************************** + + + MemoryAllocatedMsg = + 'FastMM4 nu poate fi instalat din cauza faptului ca memorie a fost deja alocata print MM implicit.' + + #13#10'FastMM4.pas TREBUIE sa fie primul unit in fisierul .dpr al proiectului Dvs.' + + #13#10#13#10'Daca utilizati un program de control al exceptiilor, cum ar fi ' + + 'MadExcept (ori orice alt instrument care modifica ordinea initializarii uniturilor' + + 'FastMM4.pas ny other unit.'; + + +//****************************************************************************************************** + + + MemoryAllocatedTitle = 'Nu pot instala FastMM4 - memorie deja alocata prin alte cai.'; + {Leak checking messages} + LeakLogHeader = 'A aparut o pierdere de memorie alocata. Adresa este: '; + LeakMessageHeader = 'Aceasta aplicatie pierde memorie. '; + SmallLeakDetail = 'Pierderile de memorie in blocurile mici sunt:'; +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluzand pierderile normale inregistrate de pointeri)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Dimensiunile blocurilor medii si mari sunt' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluzand pierderile normale inregistrate de pointeri)' +{$endif} + + ': '; + BytesMessage = ' bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Nota: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Testele de pierdere de memorie alocata sunt facute numai daca Delphi ruleaza pe acelasi computer.' + {$endif} + {$ifdef FullDebugMode} + {$ifdef LogMemoryLeakDetailToFile} + + 'Detaliile sunt inregistrate intr-un fisier text in acelasi director cu aplicatia.' + {$else} + + 'Utilizati optiunea "LogMemoryLeakDetailsToFile" pentru a obtine inregistrarile despre pierderile de memorie alocata.' + {$endif} + {$else} + + 'Pentru a obtine inregistrarile continand detalii despre pierderile de memorie, utilizati definirile conditionale "FullDebugMode" si "LogMemoryLeakDetailToFile"'; + {$endif} + + 'Pentru a dezactiva testele de meorie, nu folositi definitia conditionala "LogMemoryLeakDetailToFile"'; +{$endif} + + #0; + LeakMessageTitle = 'Pierderi de memorie alocata'; +{$ifdef UseOutputDebugString} + FastMMInstallMsg = 'FastMM a fost instalat.'; + FastMMInstallSharedMsg = 'Start al impartirii accesului la o instanta a FastMM.'; + FastMMUninstallMsg = 'FastMM a fost dezinstalat.'; + FastMMUninstallSharedMsg = 'Stop al impartirii accesului la o instanta a FastMM.'; +{$endif} +{$ifdef DetectMMOperationsAfterUninstall} + InvalidOperationTitle = 'Operatie Memory manager DUPA dezinstalater.'; + InvalidGetMemMsg = 'FastMM a detectat un apel GetMem dupa ce FastMM a fost dezinstalat.'; + InvalidFreeMemMsg = 'FastMM a detectat un apel FreeMem dupa ce FastMM a fost dezinstalat.'; + InvalidReallocMemMsg = 'FastMM a detectat un apel ReAllocMem dupa ce FastMM a fost dezinstalat.'; + InvalidAllocMemMsg = 'FastMM a detectat un apel GetMem dupa ce AllocMem a fost dezinstalat.'; +{$endif} + +implementation + +end. + diff --git a/contrib/FastMM4-AVX/Translations/Russian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Russian/FastMM4Messages.pas new file mode 100644 index 0000000..f3f7515 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Russian/FastMM4Messages.pas @@ -0,0 +1,137 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unknown'; + {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 îáíàðóæèë ÷òî áëîê áûë ìîäèôèöèðîâàí ïîñëå åãî îñâîáîæäåíèÿ. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Áûëà ïðåäïðèíÿòà ïîïûòêà îñâîáîäèòü/ïåðåâûäåëèòü íå âûäåëåííûé áëîê.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Ðàçìåð ïðåäûäóùåãî áëîêà áûë: '; + CurrentBlockSizeMsg = #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'Âûäåëåííûé íîìåð ñòàë: '; + BlockErrorMsgTitle = 'Îáíàðóæåíà îøèáêà ïàìÿòè.'; + VirtualMethodErrorHeader = 'FastMM îáíàðóæèë ïîïûòêó âûçâàòü âèðòóàëüíûé ìåòîä îñâîáîæäåííîãî îáúåêòà. Ñåé÷àñ áóäåò âûçâàíî íàðóøåíèå äîñòóïà äëÿ ïðåðûâàíèÿ òåêóùåé îïåðàöèè.'; + InterfaceErrorHeader = 'FastMM îáíàðóæèë ïîïûòêó èñïîëüçîâàòü èíòåðôåéñ îñâîáîæäåííîãî îáúåêòà. Ñåé÷àñ áóäåò âûçâàíî íàðóøåíèå äîñòóïà äëÿ ïðåðûâàíèÿ òåêóùåé îïåðàöèè.'; + BlockHeaderCorruptedNoHistoryMsg = ' Ê ñîæàëåíèþ çàãîëîâîê áëîêà ïîâðåæäåí è èñòîðèÿ íå äîñòóïíà.'; + FreedObjectClassMsg = #13#10#13#10'Êëàññ îñâîáîæäåííîãî îáúåêòà: '; + VirtualMethodName = #13#10#13#10'Âèðòóàëüíûé ìåòîä: '; + VirtualMethodOffset = 'Ñìåùåíèå +'; + VirtualMethodAddress = #13#10#13#10'Àäðåñ âèðòóàëüíîãî ìåòîäà: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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 = ' áàéò: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/Translations/Spanish/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Spanish/FastMM4Messages.pas new file mode 100644 index 0000000..e16a5da --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Spanish/FastMM4Messages.pas @@ -0,0 +1,139 @@ +{ + +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} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_ManipuladorMemoria_Reporte.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Desconocida'; + {Memory dump message} + MemoryDumpMsg = #13#10#13#10'Vaciado de memoria actual de 256 bytes en la dirección '; + {Block Error Messages} + BlockScanLogHeader = 'El bloque reservado fue registrado por LogAllocatedBlocksToFile. El tamaño es: '; + ErrorMsgHeader = 'FastMM ha detectado un error durante una operación '; + GetMemMsg = 'GetMem'; + FreeMemMsg = 'FreeMem'; + ReallocMemMsg = 'ReallocMem'; + BlockCheckMsg = 'de búsqueda de bloque libre'; + OperationMsg = '. '; + BlockHeaderCorruptedMsg = 'El encabezamiento de bloque ha sido corrompido. '; + BlockFooterCorruptedMsg = 'La terminación de bloque ha sido corrompida. '; + FreeModifiedErrorMsg = 'FastMM detectó que un bloque ha sido modificado luego de liberarse. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = 'Se realizó un intento de liberar/reasignar un bloque no reservado.'; + WrongMMFreeErrorMsg = 'Se realizó un intento de liberar/reasignar un bloque reservado a través de una instancia distinta de FastMM. Chequee las opciones de uso compartido de su manipulador de memoria.'; + PreviousBlockSizeMsg = #13#10#13#10'El tamaño anterior del bloque era: '; + CurrentBlockSizeMsg = #13#10#13#10'El tamaño del bloque es: '; + 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'El grupo de la reservación fue: '; + PreviousAllocationNumberMsg = #13#10#13#10'El número de la reservación fue: '; + CurrentAllocationGroupMsg = #13#10#13#10'El grupo de la reservación es: '; + CurrentAllocationNumberMsg = #13#10#13#10'El número de la reservación es: '; + BlockErrorMsgTitle = 'Detectado error de memoria'; + VirtualMethodErrorHeader = + 'FastMM ha detectado un intento de ejecutar un método virtual de un objeto liberado. Una violación de acceso se generará ahora para abortar la operación.'; + InterfaceErrorHeader = + 'FastMM ha detectado un intento de utlización de una interfaz de un objeto liberado. Una violación de acceso se generará ahora para abortar la operación.'; + 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'Método virtual: '; + VirtualMethodOffset = 'Desplazamiento +'; + VirtualMethodAddress = #13#10#13#10'Dirección del método virtual: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'El ID del hilo actual es 0x'; + CurrentStackTraceMsg = ', y el vaciado del stack (direcciones de retorno) que conduce a este error es:'; + ThreadIDPrevAllocMsg = #13#10#13#10'Este bloque fue previamente reservado por el hilo 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'Este bloque fue reservado por el hilo 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'Este bloque fue previamente liberado por el hilo 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'El objeto fue reservado por el hilo 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'El objeto fue posteriormente liberado por el hilo 0x'; + StackTraceMsg = ', y el vaciado del stack (direcciones de retorno) en ese momento es:'; + {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 asegúrese de que FastMM4.pas es la primera unit en la sección "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 estándar.'#13#10 + + 'FastMM4.pas TIENE que ser la primera unit en el fichero .DPR de su proyecto, de otra manera podría reservarse memoria'#13#10 + + 'mediante el manipulador de memoria estándar 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 inicialización de las units),'#13#10 + //Fixed by MFM + 'vaya a su página de configuración y asegúrese 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 = 'Ha habido una fuga de memoria. El tamaño del bloque es: '; + LeakMessageHeader = 'Esta aplicación ha tenido fugas de memoria. '; + SmallLeakDetail = 'Las fugas de memoria en los bloques pequeños son' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluyendo las fugas esperadas registradas por apuntador)' +{$endif} + + ':'#13#10; + LargeLeakDetail = 'Las fugas de memoria de bloques medianos y grandes son' +{$ifdef HideExpectedLeaksRegisteredByPointer} + + ' (excluyendo las fugas esperadas registrados por apuntador)' +{$endif} + + ': '; + BytesMessage = ' bytes: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + LeakMessageFooter = #13#10 +{$ifndef HideMemoryLeakHintMessage} + + #13#10'Nota: ' + {$ifdef RequireIDEPresenceForLeakReporting} + + 'Este chequeo de escape de memoria sólo se realiza si Delphi está ejecutándose 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 aplicación. ' + {$else} + + 'Habilite "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 deshabilitar este chequeo de fugas de memoria, indefina "EnableMemoryLeakReporting".'#13#10 +{$endif} + + #0; + LeakMessageTitle = 'Detectada fuga 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 = 'Operación 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/contrib/FastMM4-AVX/Translations/Ukrainian/FastMM4Messages.pas b/contrib/FastMM4-AVX/Translations/Ukrainian/FastMM4Messages.pas new file mode 100644 index 0000000..7bbccc7 --- /dev/null +++ b/contrib/FastMM4-AVX/Translations/Ukrainian/FastMM4Messages.pas @@ -0,0 +1,135 @@ +{ + +Fast Memory Manager: Messages + +2006-07-18 +Ukrainian translation by Andrey V. Shtukaturov. + +} + +unit FastMM4Messages; + +interface + +{$Include FastMM4Options.inc} + +const + {The name of the debug info support DLL} + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; + {Event log strings} + LogFileExtension = '_MemoryManager_EventLog.txt'#0; + CRLF = #13#10; + EventSeparator = '--------------------------------'; + {Class name messages} + UnknownClassNameMsg = 'Unknown'; + {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 âèÿâèâ ùî áëîê áóëî ìîäèô³êîâàíî ï³ñëÿ éîãî çâ³ëüíåííÿ. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; + DoubleFreeErrorMsg = ' Áóëà ñïðîáà çâ³ëüíèòè/ïåðåâèä³ëèòè íå âèä³ëåíèé áëîê.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; + PreviousBlockSizeMsg = #13#10#13#10'Ðîçì³ð ïîïåðåäíüîãî áëîêó áóâ: '; + CurrentBlockSizeMsg = #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'Âèä³ëåíèé íîìåð ñòàâ: '; + BlockErrorMsgTitle = 'Âèÿâëåíî ïîìèëêó ïàì’’ÿò³.'; + VirtualMethodErrorHeader = 'FastMM âèÿâèâ ñïðîáó âèêëèêàòè â³ðòóàëüíèé ìåòîä çâ³ëüíåíîãî îá’’ºêòó. Çàðàç áóäå âèêëèêàíå ïîðóøåííÿ äîñòóïó äëÿ ïåðåðèâàííÿ ïîòî÷íî¿ îïåðàö³¿.'; + InterfaceErrorHeader = 'FastMM âèÿâèâ ñïðîáó âèêîðèñòàòè ³íòåðôåéñ çâ³ëüíåíîãî îá’’ºêòó. Çàðàç áóäå âèêëèêàíå ïîðóøåííÿ äîñòóïó äëÿ ïåðåðèâàííÿ ïîòî÷íî¿ îïåðàö³¿.'; + BlockHeaderCorruptedNoHistoryMsg = ' Íà æàëü çàãîëîâîê áëîêó óøêîäæåíèé ³ ³ñòîð³ÿ íåäîñòóïíà.'; + FreedObjectClassMsg = #13#10#13#10'Êëàñ çâ³ëüíåíîãî îá’’ºêòó: '; + VirtualMethodName = #13#10#13#10'³ðòóàëüíèé ìåòîä: '; + VirtualMethodOffset = 'Çñóâ +'; + VirtualMethodAddress = #13#10#13#10'Àäðåñà â³ðòóàëüíîãî ìåòîäó: '; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; + {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 = ' áàéò: '; + AnsiStringBlockMessage = 'AnsiString'; + UnicodeStringBlockMessage = 'UnicodeString'; + 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/contrib/FastMM4-AVX/images/FastMM-Title.jpg b/contrib/FastMM4-AVX/images/FastMM-Title.jpg new file mode 100644 index 0000000..e464a79 Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM-Title.jpg differ diff --git a/contrib/FastMM4-AVX/images/FastMM-simple.jpg b/contrib/FastMM4-AVX/images/FastMM-simple.jpg new file mode 100644 index 0000000..069b215 Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM-simple.jpg differ diff --git a/contrib/FastMM4-AVX/images/FastMM-square-title.jpg b/contrib/FastMM4-AVX/images/FastMM-square-title.jpg new file mode 100644 index 0000000..8002cbc Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM-square-title.jpg differ diff --git a/contrib/FastMM4-AVX/images/FastMM-square.jpg b/contrib/FastMM4-AVX/images/FastMM-square.jpg new file mode 100644 index 0000000..472a714 Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM-square.jpg differ diff --git a/contrib/FastMM4-AVX/images/FastMM.jpg b/contrib/FastMM4-AVX/images/FastMM.jpg new file mode 100644 index 0000000..9dfb881 Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM.jpg differ diff --git a/contrib/FastMM4-AVX/images/FastMM.png b/contrib/FastMM4-AVX/images/FastMM.png new file mode 100644 index 0000000..319f4fa Binary files /dev/null and b/contrib/FastMM4-AVX/images/FastMM.png differ diff --git a/contrib/FastMM4-AVX/images/readme.md b/contrib/FastMM4-AVX/images/readme.md new file mode 100644 index 0000000..82a83b5 --- /dev/null +++ b/contrib/FastMM4-AVX/images/readme.md @@ -0,0 +1,22 @@ +These images were created by Jim McKeeth of Embarcadero Technologies to help recognize Pierre le Riche's FastMM4 project are and licensed under for unlimited use by Pierre le Riche and the FastMM4 project. + +[FastMM.png transparent](FastMM.png "FastMM.png transparent") +![FastMM.png transparent](FastMM.png "FastMM.png transparent") + +[FastMM-square-title.jpg square](FastMM-square-title.jpg "FastMM-square-title.jpg square") +![FastMM-square-title.jpg square](FastMM-square-title.jpg "FastMM-square-title.jpg square") + +[FastMM.jpg with full text](FastMM.jpg "FastMM.jpg with full text") +![FastMM.jpg with full text](FastMM.jpg "FastMM.jpg with full text") + +[FastMM-simple.jpg with simple text](FastMM-simple.jpg "FastMM-simple.jpg with simple text") +![FastMM-simple.jpg with simple text](FastMM-simple.jpg "FastMM-simple.jpg with simple text") + +[FastMM-Title.jpg with title only](FastMM-Title.jpg "FastMM-Title.jpg with title only") +![FastMM-Title.jpg with title only](FastMM-Title.jpg "FastMM-Title.jpg with title only") + +## Image credits +* Stopwatch by Skeeze https://pixabay.com/photo-2624277/ (CC0) +* Memory from PD Pictures https://pixabay.com/photo-20072/ (CC0) +* Font DigitalDream by Jakob Fischer www.pizzadude.dk - https://www.1001fonts.com/digital-dream-font.html (licensed commercial and personal use) +* Suplemental font Segoe UI https://docs.microsoft.com/en-us/typography/font-list/segoe-ui diff --git a/contrib/FastMM4-AVX/license_gpl.txt b/contrib/FastMM4-AVX/license_gpl.txt new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/contrib/FastMM4-AVX/license_gpl.txt @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/contrib/FastMM4-AVX/license_lgpl.txt b/contrib/FastMM4-AVX/license_lgpl.txt new file mode 100644 index 0000000..65c5ca8 --- /dev/null +++ b/contrib/FastMM4-AVX/license_lgpl.txt @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/contrib/ParseExpression/__history/ParseClass.pas.~1~ b/contrib/ParseExpression/__history/ParseClass.pas.~1~ deleted file mode 100644 index f3c4881..0000000 --- a/contrib/ParseExpression/__history/ParseClass.pas.~1~ +++ /dev/null @@ -1,719 +0,0 @@ -unit ParseClass; - -interface - -uses OObjects, SysUtils; - -const - MaxArg = 6; - -const - Nan: Double = 0 / 0; -function isNan(const d: Double): boolean; - -type - TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket, - vtRightBracket, vtComma); - PDouble = ^Double; - EParserException = class(Exception); - PExpressionRec = ^TExpressionRec; - - TExprWord = class; - - TArgsArray = record - Res: Double; - Args: array [0 .. MaxArg - 1] of PDouble; - ExprWord: TExprWord; // can be used to notify the object to update - end; - - TDoubleFunc = procedure(Expr: PExpressionRec); - - TStringFunc = function(s1, s2: string): Double; - - TExpressionRec = record - // used both as linked tree and linked list for maximum evaluation efficiency - Oper: TDoubleFunc; - Next: PExpressionRec; - Res: Double; - ExprWord: TExprWord; - case Byte of - 0: - (Args: array [0 .. MaxArg - 1] of PDouble; - // can be used to notify the object to update - ); - 1: - (ArgList: array [0 .. MaxArg - 1] of PExpressionRec); - end; - - TExprCollection = class(TNoOwnerCollection) - public - function NextOper(IStart: Integer): Integer; - procedure Check; - procedure EraseExtraBrackets; - end; - - TExprWord = class - private - FName: string; - FDoubleFunc: TDoubleFunc; - protected - function GetIsOper: boolean; virtual; - function GetAsString: string; virtual; - function GetIsVariable: boolean; - function GetCanVary: boolean; virtual; - function GetVarType: TVarType; virtual; - function GetNFunctionArg: Integer; virtual; - function GetDescription: string; virtual; - public - constructor Create(AName: string; ADoubleFunc: TDoubleFunc); - function AsPointer: PDouble; virtual; - property AsString: string read GetAsString; - property DoubleFunc: TDoubleFunc read FDoubleFunc; - property IsOper: boolean read GetIsOper; - property CanVary: boolean read GetCanVary; - property isVariable: boolean read GetIsVariable; - property VarType: TVarType read GetVarType; - property NFunctionArg: Integer read GetNFunctionArg; - property Name: string read FName; - property Description: string read GetDescription; - end; - - TExpressList = class(TSortedCollection) - public - function KeyOf(Item: Pointer): Pointer; override; - function Compare(Key1, Key2: Pointer): Integer; override; - end; - - TDoubleConstant = class(TExprWord) - private - FValue: Double; - public - function AsPointer: PDouble; override; - constructor Create(AName: string; AValue: string); - constructor CreateAsDouble(AName: string; AValue: Double); - // not overloaded to support older Delphi versions - property Value: Double read FValue write FValue; - end; - - TConstant = class(TDoubleConstant) - private - FDescription: string; - protected - function GetDescription: string; override; - public - constructor CreateAsDouble(AName, Descr: string; AValue: Double); - end; - - TBooleanConstant = class(TDoubleConstant) - protected - function GetVarType: TVarType; override; - end; - - TGeneratedVariable = class(TDoubleConstant) - private - FAsString: string; - FVarType: TVarType; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - function GetCanVary: boolean; override; - public - constructor Create(AName: string); - property VarType read GetVarType write FVarType; - property AsString: string read GetAsString write FAsString; - end; - - TDoubleVariable = class(TExprWord) - private - FValue: PDouble; - protected - function GetCanVary: boolean; override; - public - function AsPointer: PDouble; override; - constructor Create(AName: string; AValue: PDouble); - end; - - TStringConstant = class(TExprWord) - private - FValue: string; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - public - constructor Create(AValue: string); - end; - - TLeftBracket = class(TExprWord) - function GetVarType: TVarType; override; - end; - - TRightBracket = class(TExprWord) - protected - function GetVarType: TVarType; override; - end; - - TComma = class(TExprWord) - protected - function GetVarType: TVarType; override; - end; - - PString = ^string; - - TStringVariable = class(TExprWord) - private - FValue: PString; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - function GetCanVary: boolean; override; - public - constructor Create(AName: string; AValue: PString); - end; - - TFunction = class(TExprWord) - private - FIsOper: boolean; - FOperPrec: Integer; - FNFunctionArg: Integer; - FDescription: string; - protected - function GetDescription: string; override; - function GetIsOper: boolean; override; - function GetNFunctionArg: Integer; override; - public - constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer); - constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer); - property OperPrec: Integer read FOperPrec; - end; - - TVaryingFunction = class(TFunction) - // Functions that can vary for ex. random generators - // should be TVaryingFunction to be sure that they are - // always evaluated - protected - function GetCanVary: boolean; override; - end; - - TBooleanFunction = class(TFunction) - protected - function GetVarType: TVarType; override; - end; - - TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in); - -const - ListChar = ','; { the delimiter used with the 'in' operator: e.g., - ('a' in 'a,b') =True - ('c' in 'a,b') =False } - -type - TSimpleStringFunction = class(TFunction) - private - FStringFunc: TStringFunc; - FLeftArg: TExprWord; - FRightArg: TExprWord; - protected - function GetCanVary: boolean; override; - public - constructor Create(AName, Descr: string; AStringFunc: TStringFunc; - ALeftArg, ARightArg: TExprWord); - function Evaluate: Double; - property StringFunc: TStringFunc read FStringFunc; - end; - - TVaryingStringFunction = class(TSimpleStringFunction) - protected - function GetCanVary: boolean; override; - end; - - TLogicalStringOper = class(TSimpleStringFunction) - protected - function GetVarType: TVarType; override; - public - constructor Create(AOper: string; ALeftArg: TExprWord; - ARightArg: TExprWord); - end; - -procedure _Variable(Param: PExpressionRec); - -// procedure _StringFunc(Param: PExpressionRec); - -implementation - -// function _StrIn(sLookfor, sData: string): Double; - -// function _StrInt(a, b: string): Double; - -function isNan(const d: Double): boolean; -begin - Result := comp(d) = comp(Nan); - // slower alternative: CompareMem(@d, @Nan, SizeOf(Double)) -end; - -procedure _Variable(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^; -end; - -procedure _StringFunc(Param: PExpressionRec); -begin - with Param^ do - Res := TSimpleStringFunction(ExprWord).Evaluate; -end; - -function _StrInt(a, b: string): Double; -begin - Result := StrToInt(a); -end; - -function _StrEq(s1, s2: string): Double; -begin - Result := Byte(s1 = s2); -end; - -function _StrGt(s1, s2: string): Double; -begin - Result := Byte(s1 > s2); -end; - -function _Strlt(s1, s2: string): Double; -begin - Result := Byte(s1 < s2); -end; - -function _StrGe(s1, s2: string): Double; -begin - Result := Byte(s1 >= s2); -end; - -function _Strle(s1, s2: string): Double; -begin - Result := Byte(s1 <= s2); -end; - -function _Strne(s1, s2: string): Double; -begin - Result := Byte(s1 <> s2); -end; - -function _StrIn(sLookfor, sData: string): Double; -var - loop: Integer; - subString: string; -begin - Result := 0; - loop := pos(ListChar, sData); - while loop > 0 do - begin - subString := Copy(sData, 1, loop - 1); - sData := Copy(sData, loop + 1, Length(sData)); - if subString = sLookfor then - begin - Result := 1; - break; - end; - loop := pos(ListChar, sData); - end; - if sLookfor = sData then - Result := 1; -end; - -{ TExpressionWord } - -function TExprWord.AsPointer: PDouble; -begin - Result := nil; -end; - -constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc); -begin - FName := LowerCase(AName); - FDoubleFunc := ADoubleFunc; -end; - -function TExprWord.GetAsString: string; -begin - Result := ''; -end; - -function TExprWord.GetCanVary: boolean; -begin - Result := False; -end; - -function TExprWord.GetDescription: string; -begin - Result := ''; -end; - -function TExprWord.GetIsOper: boolean; -begin - Result := False; -end; - -function TExprWord.GetIsVariable: boolean; -begin - Result := @FDoubleFunc = @_Variable -end; - -function TExprWord.GetNFunctionArg: Integer; -begin - Result := 0; -end; - -function TExprWord.GetVarType: TVarType; -begin - Result := vtDouble; -end; - -{ TDoubleConstant } - -function TDoubleConstant.AsPointer: PDouble; -begin - Result := @FValue; -end; - -constructor TDoubleConstant.Create(AName, AValue: string); -begin - inherited Create(AName, _Variable); - if AValue <> '' then - FValue := StrToFloat(AValue) - else - FValue := Nan; -end; - -constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -{ TStringConstant } - -function TStringConstant.GetAsString: string; -begin - Result := FValue; -end; - -constructor TStringConstant.Create(AValue: string); -begin - inherited Create(AValue, _Variable); - if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then - FValue := Copy(AValue, 2, Length(AValue) - 2) - else - FValue := AValue; -end; - -function TStringConstant.GetVarType: TVarType; -begin - Result := vtString; -end; - -{ TDoubleVariable } - -function TDoubleVariable.AsPointer: PDouble; -begin - Result := FValue; -end; - -constructor TDoubleVariable.Create(AName: string; AValue: PDouble); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -function TDoubleVariable.GetCanVary: boolean; -begin - Result := True; -end; - -{ TFunction } - -constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer); -begin - FDescription := Descr; - CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0); - // to increase compatibility don't use default parameters -end; - -constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer); -begin - inherited Create(AName, ADoubleFunc); - FNFunctionArg := ANFunctionArg; - if FNFunctionArg > MaxArg then - raise EParserException.Create('Too many arguments'); - FIsOper := AIsOper; - FOperPrec := AOperPrec; -end; - -function TFunction.GetDescription: string; -begin - Result := FDescription; -end; - -function TFunction.GetIsOper: boolean; -begin - Result := FIsOper; -end; - -function TFunction.GetNFunctionArg: Integer; -begin - Result := FNFunctionArg; -end; - -{ TLeftBracket } - -function TLeftBracket.GetVarType: TVarType; -begin - Result := vtLeftBracket; -end; - -{ TExpressList } - -function TExpressList.Compare(Key1, Key2: Pointer): Integer; -begin - Result := StrIComp(Pchar(Key1), Pchar(Key2)); -end; - -function TExpressList.KeyOf(Item: Pointer): Pointer; -begin - Result := Pchar(TExprWord(Item).Name); -end; - -{ TRightBracket } - -function TRightBracket.GetVarType: TVarType; -begin - Result := vtRightBracket; -end; - -{ TComma } - -function TComma.GetVarType: TVarType; -begin - Result := vtComma; -end; - -{ TExprCollection } - -procedure TExprCollection.Check; -var - brCount, I: Integer; -begin - brCount := 0; - for I := 0 to Count - 1 do - begin - case TExprWord(Items[I]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - end; - if brCount <> 0 then - raise EParserException.Create('Unequal brackets'); -end; - -procedure TExprCollection.EraseExtraBrackets; -var - I: Integer; - brCount: Integer; -begin - if (TExprWord(Items[0]).VarType = vtLeftBracket) then - begin - brCount := 1; - I := 1; - while (I < Count) and (brCount > 0) do - begin - case TExprWord(Items[I]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - Inc(I); - end; - if (brCount = 0) and (I = Count) and - (TExprWord(Items[I - 1]).VarType = vtRightBracket) then - begin - for I := 0 to Count - 3 do - Items[I] := Items[I + 1]; - Count := Count - 2; - EraseExtraBrackets; // Check if there are still too many brackets - end; - end; -end; - -function TExprCollection.NextOper(IStart: Integer): Integer; -var - brCount: Integer; -begin - brCount := 0; - Result := IStart; - while (Result < Count) and - ((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do - begin - case TExprWord(Items[Result]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - Inc(Result); - end; -end; - -{ TStringVariable } - -function TStringVariable.GetAsString: string; -begin - if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then - Result := Copy(FValue^, 2, Length(FValue^) - 2) - else - Result := FValue^ -end; - -constructor TStringVariable.Create(AName: string; AValue: PString); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -function TStringVariable.GetVarType: TVarType; -begin - Result := vtString; -end; - -function TStringVariable.GetCanVary: boolean; -begin - Result := True; -end; - -{ TLogicalStringOper } - -constructor TLogicalStringOper.Create(AOper: string; - ALeftArg, ARightArg: TExprWord); -begin - if AOper = '=' then - FStringFunc := @_StrEq - else if AOper = '>' then - FStringFunc := @_StrGt - else if AOper = '<' then - FStringFunc := @_Strlt - else if AOper = '>=' then - FStringFunc := @_StrGe - else if AOper = '<=' then - FStringFunc := @_Strle - else if AOper = '<>' then - FStringFunc := @_Strne - else if AOper = 'in' then - FStringFunc := @_StrIn - else - raise EParserException.Create(AOper + ' is not a valid string operand'); - inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg); -end; - -function TLogicalStringOper.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TBooleanFunction } - -function TBooleanFunction.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TGeneratedVariable } - -constructor TGeneratedVariable.Create(AName: string); -begin - inherited Create(AName, ''); - FAsString := ''; - FVarType := vtDouble; -end; - -function TGeneratedVariable.GetAsString: string; -begin - Result := FAsString; -end; - -function TGeneratedVariable.GetCanVary: boolean; -begin - Result := True; -end; - -function TGeneratedVariable.GetVarType: TVarType; -begin - Result := FVarType; -end; - -{ TVaryingFunction } - -function TVaryingFunction.GetCanVary: boolean; -begin - Result := True; -end; - -{ TBooleanConstant } - -function TBooleanConstant.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TConstant } - -constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double); -begin - FDescription := Descr; - inherited CreateAsDouble(AName, AValue); -end; - -function TConstant.GetDescription: string; -begin - Result := FDescription; -end; - -{ TSimpleStringFunction } - -constructor TSimpleStringFunction.Create(AName, Descr: string; - AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord); -begin - FStringFunc := @AStringFunc; - FLeftArg := ALeftArg; - FRightArg := ARightArg; - inherited Create(AName, Descr, _StringFunc, 0) -end; - -function TSimpleStringFunction.Evaluate: Double; -var - s1, s2: string; -begin - s1 := FLeftArg.AsString; - if FRightArg <> nil then - s2 := FRightArg.AsString - else - s2 := ''; - Result := StringFunc(s1, s2); -end; - -function TSimpleStringFunction.GetCanVary: boolean; -begin - Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or - ((FRightArg <> nil) and FRightArg.CanVary); -end; -{ TVaryingStringFunction } - -function TVaryingStringFunction.GetCanVary: boolean; -begin - Result := True; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseClass.pas.~2~ b/contrib/ParseExpression/__history/ParseClass.pas.~2~ deleted file mode 100644 index 1da1e03..0000000 --- a/contrib/ParseExpression/__history/ParseClass.pas.~2~ +++ /dev/null @@ -1,719 +0,0 @@ -unit ParseClass; - -interface - -uses OObjects, SysUtils; - -const - MaxArg = 1000; - -const - Nan: Double = 0 / 0; -function isNan(const d: Double): boolean; - -type - TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket, - vtRightBracket, vtComma); - PDouble = ^Double; - EParserException = class(Exception); - PExpressionRec = ^TExpressionRec; - - TExprWord = class; - - TArgsArray = record - Res: Double; - Args: array [0 .. MaxArg - 1] of PDouble; - ExprWord: TExprWord; // can be used to notify the object to update - end; - - TDoubleFunc = procedure(Expr: PExpressionRec); - - TStringFunc = function(s1, s2: string): Double; - - TExpressionRec = record - // used both as linked tree and linked list for maximum evaluation efficiency - Oper: TDoubleFunc; - Next: PExpressionRec; - Res: Double; - ExprWord: TExprWord; - case Byte of - 0: - (Args: array [0 .. MaxArg - 1] of PDouble; - // can be used to notify the object to update - ); - 1: - (ArgList: array [0 .. MaxArg - 1] of PExpressionRec); - end; - - TExprCollection = class(TNoOwnerCollection) - public - function NextOper(IStart: Integer): Integer; - procedure Check; - procedure EraseExtraBrackets; - end; - - TExprWord = class - private - FName: string; - FDoubleFunc: TDoubleFunc; - protected - function GetIsOper: boolean; virtual; - function GetAsString: string; virtual; - function GetIsVariable: boolean; - function GetCanVary: boolean; virtual; - function GetVarType: TVarType; virtual; - function GetNFunctionArg: Integer; virtual; - function GetDescription: string; virtual; - public - constructor Create(AName: string; ADoubleFunc: TDoubleFunc); - function AsPointer: PDouble; virtual; - property AsString: string read GetAsString; - property DoubleFunc: TDoubleFunc read FDoubleFunc; - property IsOper: boolean read GetIsOper; - property CanVary: boolean read GetCanVary; - property isVariable: boolean read GetIsVariable; - property VarType: TVarType read GetVarType; - property NFunctionArg: Integer read GetNFunctionArg; - property Name: string read FName; - property Description: string read GetDescription; - end; - - TExpressList = class(TSortedCollection) - public - function KeyOf(Item: Pointer): Pointer; override; - function Compare(Key1, Key2: Pointer): Integer; override; - end; - - TDoubleConstant = class(TExprWord) - private - FValue: Double; - public - function AsPointer: PDouble; override; - constructor Create(AName: string; AValue: string); - constructor CreateAsDouble(AName: string; AValue: Double); - // not overloaded to support older Delphi versions - property Value: Double read FValue write FValue; - end; - - TConstant = class(TDoubleConstant) - private - FDescription: string; - protected - function GetDescription: string; override; - public - constructor CreateAsDouble(AName, Descr: string; AValue: Double); - end; - - TBooleanConstant = class(TDoubleConstant) - protected - function GetVarType: TVarType; override; - end; - - TGeneratedVariable = class(TDoubleConstant) - private - FAsString: string; - FVarType: TVarType; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - function GetCanVary: boolean; override; - public - constructor Create(AName: string); - property VarType read GetVarType write FVarType; - property AsString: string read GetAsString write FAsString; - end; - - TDoubleVariable = class(TExprWord) - private - FValue: PDouble; - protected - function GetCanVary: boolean; override; - public - function AsPointer: PDouble; override; - constructor Create(AName: string; AValue: PDouble); - end; - - TStringConstant = class(TExprWord) - private - FValue: string; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - public - constructor Create(AValue: string); - end; - - TLeftBracket = class(TExprWord) - function GetVarType: TVarType; override; - end; - - TRightBracket = class(TExprWord) - protected - function GetVarType: TVarType; override; - end; - - TComma = class(TExprWord) - protected - function GetVarType: TVarType; override; - end; - - PString = ^string; - - TStringVariable = class(TExprWord) - private - FValue: PString; - protected - function GetVarType: TVarType; override; - function GetAsString: string; override; - function GetCanVary: boolean; override; - public - constructor Create(AName: string; AValue: PString); - end; - - TFunction = class(TExprWord) - private - FIsOper: boolean; - FOperPrec: Integer; - FNFunctionArg: Integer; - FDescription: string; - protected - function GetDescription: string; override; - function GetIsOper: boolean; override; - function GetNFunctionArg: Integer; override; - public - constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer); - constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer); - property OperPrec: Integer read FOperPrec; - end; - - TVaryingFunction = class(TFunction) - // Functions that can vary for ex. random generators - // should be TVaryingFunction to be sure that they are - // always evaluated - protected - function GetCanVary: boolean; override; - end; - - TBooleanFunction = class(TFunction) - protected - function GetVarType: TVarType; override; - end; - - TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in); - -const - ListChar = ','; { the delimiter used with the 'in' operator: e.g., - ('a' in 'a,b') =True - ('c' in 'a,b') =False } - -type - TSimpleStringFunction = class(TFunction) - private - FStringFunc: TStringFunc; - FLeftArg: TExprWord; - FRightArg: TExprWord; - protected - function GetCanVary: boolean; override; - public - constructor Create(AName, Descr: string; AStringFunc: TStringFunc; - ALeftArg, ARightArg: TExprWord); - function Evaluate: Double; - property StringFunc: TStringFunc read FStringFunc; - end; - - TVaryingStringFunction = class(TSimpleStringFunction) - protected - function GetCanVary: boolean; override; - end; - - TLogicalStringOper = class(TSimpleStringFunction) - protected - function GetVarType: TVarType; override; - public - constructor Create(AOper: string; ALeftArg: TExprWord; - ARightArg: TExprWord); - end; - -procedure _Variable(Param: PExpressionRec); - -// procedure _StringFunc(Param: PExpressionRec); - -implementation - -// function _StrIn(sLookfor, sData: string): Double; - -// function _StrInt(a, b: string): Double; - -function isNan(const d: Double): boolean; -begin - Result := comp(d) = comp(Nan); - // slower alternative: CompareMem(@d, @Nan, SizeOf(Double)) -end; - -procedure _Variable(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^; -end; - -procedure _StringFunc(Param: PExpressionRec); -begin - with Param^ do - Res := TSimpleStringFunction(ExprWord).Evaluate; -end; - -function _StrInt(a, b: string): Double; -begin - Result := StrToInt(a); -end; - -function _StrEq(s1, s2: string): Double; -begin - Result := Byte(s1 = s2); -end; - -function _StrGt(s1, s2: string): Double; -begin - Result := Byte(s1 > s2); -end; - -function _Strlt(s1, s2: string): Double; -begin - Result := Byte(s1 < s2); -end; - -function _StrGe(s1, s2: string): Double; -begin - Result := Byte(s1 >= s2); -end; - -function _Strle(s1, s2: string): Double; -begin - Result := Byte(s1 <= s2); -end; - -function _Strne(s1, s2: string): Double; -begin - Result := Byte(s1 <> s2); -end; - -function _StrIn(sLookfor, sData: string): Double; -var - loop: Integer; - subString: string; -begin - Result := 0; - loop := pos(ListChar, sData); - while loop > 0 do - begin - subString := Copy(sData, 1, loop - 1); - sData := Copy(sData, loop + 1, Length(sData)); - if subString = sLookfor then - begin - Result := 1; - break; - end; - loop := pos(ListChar, sData); - end; - if sLookfor = sData then - Result := 1; -end; - -{ TExpressionWord } - -function TExprWord.AsPointer: PDouble; -begin - Result := nil; -end; - -constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc); -begin - FName := LowerCase(AName); - FDoubleFunc := ADoubleFunc; -end; - -function TExprWord.GetAsString: string; -begin - Result := ''; -end; - -function TExprWord.GetCanVary: boolean; -begin - Result := False; -end; - -function TExprWord.GetDescription: string; -begin - Result := ''; -end; - -function TExprWord.GetIsOper: boolean; -begin - Result := False; -end; - -function TExprWord.GetIsVariable: boolean; -begin - Result := @FDoubleFunc = @_Variable -end; - -function TExprWord.GetNFunctionArg: Integer; -begin - Result := 0; -end; - -function TExprWord.GetVarType: TVarType; -begin - Result := vtDouble; -end; - -{ TDoubleConstant } - -function TDoubleConstant.AsPointer: PDouble; -begin - Result := @FValue; -end; - -constructor TDoubleConstant.Create(AName, AValue: string); -begin - inherited Create(AName, _Variable); - if AValue <> '' then - FValue := StrToFloat(AValue) - else - FValue := Nan; -end; - -constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -{ TStringConstant } - -function TStringConstant.GetAsString: string; -begin - Result := FValue; -end; - -constructor TStringConstant.Create(AValue: string); -begin - inherited Create(AValue, _Variable); - if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then - FValue := Copy(AValue, 2, Length(AValue) - 2) - else - FValue := AValue; -end; - -function TStringConstant.GetVarType: TVarType; -begin - Result := vtString; -end; - -{ TDoubleVariable } - -function TDoubleVariable.AsPointer: PDouble; -begin - Result := FValue; -end; - -constructor TDoubleVariable.Create(AName: string; AValue: PDouble); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -function TDoubleVariable.GetCanVary: boolean; -begin - Result := True; -end; - -{ TFunction } - -constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer); -begin - FDescription := Descr; - CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0); - // to increase compatibility don't use default parameters -end; - -constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc; - ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer); -begin - inherited Create(AName, ADoubleFunc); - FNFunctionArg := ANFunctionArg; - if FNFunctionArg > MaxArg then - raise EParserException.Create('Too many arguments'); - FIsOper := AIsOper; - FOperPrec := AOperPrec; -end; - -function TFunction.GetDescription: string; -begin - Result := FDescription; -end; - -function TFunction.GetIsOper: boolean; -begin - Result := FIsOper; -end; - -function TFunction.GetNFunctionArg: Integer; -begin - Result := FNFunctionArg; -end; - -{ TLeftBracket } - -function TLeftBracket.GetVarType: TVarType; -begin - Result := vtLeftBracket; -end; - -{ TExpressList } - -function TExpressList.Compare(Key1, Key2: Pointer): Integer; -begin - Result := StrIComp(Pchar(Key1), Pchar(Key2)); -end; - -function TExpressList.KeyOf(Item: Pointer): Pointer; -begin - Result := Pchar(TExprWord(Item).Name); -end; - -{ TRightBracket } - -function TRightBracket.GetVarType: TVarType; -begin - Result := vtRightBracket; -end; - -{ TComma } - -function TComma.GetVarType: TVarType; -begin - Result := vtComma; -end; - -{ TExprCollection } - -procedure TExprCollection.Check; -var - brCount, I: Integer; -begin - brCount := 0; - for I := 0 to Count - 1 do - begin - case TExprWord(Items[I]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - end; - if brCount <> 0 then - raise EParserException.Create('Unequal brackets'); -end; - -procedure TExprCollection.EraseExtraBrackets; -var - I: Integer; - brCount: Integer; -begin - if (TExprWord(Items[0]).VarType = vtLeftBracket) then - begin - brCount := 1; - I := 1; - while (I < Count) and (brCount > 0) do - begin - case TExprWord(Items[I]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - Inc(I); - end; - if (brCount = 0) and (I = Count) and - (TExprWord(Items[I - 1]).VarType = vtRightBracket) then - begin - for I := 0 to Count - 3 do - Items[I] := Items[I + 1]; - Count := Count - 2; - EraseExtraBrackets; // Check if there are still too many brackets - end; - end; -end; - -function TExprCollection.NextOper(IStart: Integer): Integer; -var - brCount: Integer; -begin - brCount := 0; - Result := IStart; - while (Result < Count) and - ((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do - begin - case TExprWord(Items[Result]).VarType of - vtLeftBracket: - Inc(brCount); - vtRightBracket: - Dec(brCount); - end; - Inc(Result); - end; -end; - -{ TStringVariable } - -function TStringVariable.GetAsString: string; -begin - if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then - Result := Copy(FValue^, 2, Length(FValue^) - 2) - else - Result := FValue^ -end; - -constructor TStringVariable.Create(AName: string; AValue: PString); -begin - inherited Create(AName, _Variable); - FValue := AValue; -end; - -function TStringVariable.GetVarType: TVarType; -begin - Result := vtString; -end; - -function TStringVariable.GetCanVary: boolean; -begin - Result := True; -end; - -{ TLogicalStringOper } - -constructor TLogicalStringOper.Create(AOper: string; - ALeftArg, ARightArg: TExprWord); -begin - if AOper = '=' then - FStringFunc := @_StrEq - else if AOper = '>' then - FStringFunc := @_StrGt - else if AOper = '<' then - FStringFunc := @_Strlt - else if AOper = '>=' then - FStringFunc := @_StrGe - else if AOper = '<=' then - FStringFunc := @_Strle - else if AOper = '<>' then - FStringFunc := @_Strne - else if AOper = 'in' then - FStringFunc := @_StrIn - else - raise EParserException.Create(AOper + ' is not a valid string operand'); - inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg); -end; - -function TLogicalStringOper.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TBooleanFunction } - -function TBooleanFunction.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TGeneratedVariable } - -constructor TGeneratedVariable.Create(AName: string); -begin - inherited Create(AName, ''); - FAsString := ''; - FVarType := vtDouble; -end; - -function TGeneratedVariable.GetAsString: string; -begin - Result := FAsString; -end; - -function TGeneratedVariable.GetCanVary: boolean; -begin - Result := True; -end; - -function TGeneratedVariable.GetVarType: TVarType; -begin - Result := FVarType; -end; - -{ TVaryingFunction } - -function TVaryingFunction.GetCanVary: boolean; -begin - Result := True; -end; - -{ TBooleanConstant } - -function TBooleanConstant.GetVarType: TVarType; -begin - Result := vtBoolean; -end; - -{ TConstant } - -constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double); -begin - FDescription := Descr; - inherited CreateAsDouble(AName, AValue); -end; - -function TConstant.GetDescription: string; -begin - Result := FDescription; -end; - -{ TSimpleStringFunction } - -constructor TSimpleStringFunction.Create(AName, Descr: string; - AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord); -begin - FStringFunc := @AStringFunc; - FLeftArg := ALeftArg; - FRightArg := ARightArg; - inherited Create(AName, Descr, _StringFunc, 0) -end; - -function TSimpleStringFunction.Evaluate: Double; -var - s1, s2: string; -begin - s1 := FLeftArg.AsString; - if FRightArg <> nil then - s2 := FRightArg.AsString - else - s2 := ''; - Result := StringFunc(s1, s2); -end; - -function TSimpleStringFunction.GetCanVary: boolean; -begin - Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or - ((FRightArg <> nil) and FRightArg.CanVary); -end; -{ TVaryingStringFunction } - -function TVaryingStringFunction.GetCanVary: boolean; -begin - Result := True; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~10~ b/contrib/ParseExpression/__history/ParseExpr.pas.~10~ deleted file mode 100644 index 9aff4c4..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~10~ +++ /dev/null @@ -1,1912 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~11~ b/contrib/ParseExpression/__history/ParseExpr.pas.~11~ deleted file mode 100644 index cfa0ff0..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~11~ +++ /dev/null @@ -1,1914 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~12~ b/contrib/ParseExpression/__history/ParseExpr.pas.~12~ deleted file mode 100644 index 088b5b9..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~12~ +++ /dev/null @@ -1,1913 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of rad to degrees', _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~13~ b/contrib/ParseExpression/__history/ParseExpr.pas.~13~ deleted file mode 100644 index d512bb1..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~13~ +++ /dev/null @@ -1,1921 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass, Utils; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -procedure _bits(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := RadToDeg(Args[0]^); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of bits from ordinals', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~14~ b/contrib/ParseExpression/__history/ParseExpr.pas.~14~ deleted file mode 100644 index 0cbaa9b..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~14~ +++ /dev/null @@ -1,1920 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass, Utils; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -procedure _bits(Param: PExpressionRec); -begin - with Param^ do - Res := GetBits(Args[0]^, Args[2]^, Args[2]^); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of bits from ordinals', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~15~ b/contrib/ParseExpression/__history/ParseExpr.pas.~15~ deleted file mode 100644 index c49ac56..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~15~ +++ /dev/null @@ -1,1920 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass, Utils; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -procedure _bits(Param: PExpressionRec); -begin - with Param^ do - Res := GetBits(Round(Args[0]^), Round(Args[1]^), Round(Args[2]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of bits from ordinals', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~16~ b/contrib/ParseExpression/__history/ParseExpr.pas.~16~ deleted file mode 100644 index c49ac56..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~16~ +++ /dev/null @@ -1,1920 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass, Utils; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -procedure _bits(Param: PExpressionRec); -begin - with Param^ do - Res := GetBits(Round(Args[0]^), Round(Args[1]^), Round(Args[2]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of bits from ordinals', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~17~ b/contrib/ParseExpression/__history/ParseExpr.pas.~17~ deleted file mode 100644 index 5272a7d..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~17~ +++ /dev/null @@ -1,1919 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass, Utils; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -procedure _bits(Param: PExpressionRec); -begin - with Param^ do - Res := GetBits(Round(Args[0]^), Round(Args[1]^), Round(Args[2]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - Add(TFunction.Create('bits', 'conversion of bits from ordinals', _bits, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~8~ b/contrib/ParseExpression/__history/ParseExpr.pas.~8~ deleted file mode 100644 index 10f39a3..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~8~ +++ /dev/null @@ -1,1912 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/ParseExpr.pas.~9~ b/contrib/ParseExpression/__history/ParseExpr.pas.~9~ deleted file mode 100644 index 9aff4c4..0000000 --- a/contrib/ParseExpression/__history/ParseExpr.pas.~9~ +++ /dev/null @@ -1,1912 +0,0 @@ -unit ParseExpr; - -{ -------------------------------------------------------------- - | TExpressionParser - | a flexible and fast expression parser for logical and - | mathematical functions - | Author: Egbert van Nes (Egbert.vanNes@wur.nl) - | With contributions of: John Bultena, Ralf Junker, Arnulf Sortland - | and Xavier Mor-Mur - | Status: Freeware with source - | Version: 1.2 - | Date: Sept 2002 - | Homepage: http://www.dow.wau.nl/aew/parseexpr.html - | - | The fast evaluation algorithm ('pseudo-compiler' generating a linked list - | that evaluates fast) is based upon TParser - an extremely fast component - | for parsing and evaluating mathematical expressions - |('pseudo-compiled' code is only 40-80% slower than compiled Delphi code). - | - | see also: http://www.datalog.ro/delphi/parser.html - | (Renate Schaaf (schaaf@math.usu.edu), 1993 - | Alin Flaider (aflaidar@datalog.ro), 1996 - | Version 9-10: Stefan Hoffmeister, 1996-1997) - | - | I used this valuable free parser for some years but needed to add logical - | operands, which was more difficult for me than rewriting the parser. - | - | TExpressionParser is approximately equally fast in evaluating - | expressions as TParser, but the compiling is made object oriented, - | and programmed recursively, requiring much less code and making - | it easier to customize the parser. Furthermore, there are several operands added: - | comparison: > < <> = <= >= (work also on strings) - | logical: and or xor not - | factorial: ! - | percentage: % - | assign to variables: := - | user defined functions can have maximal maxArg (=4) parameters - | set MaxArg (in unit ParseClass) to a higher value if needed. - | - | The required format of the expression is Pascal style with - | the following additional operands: - | - factorial (x!) - | - power (x^y) - | - pecentage (x%) - | - | Implicit multiplying is not supported: e.g. (X+1)(24-3) generates - | a syntax error and should be replaced by (x+1)*(24-3) - | - | Logical functions evaluate in 0 if False and 1 if True - | The AsString property returns True/False if the expression is logical. - | - | The comparison functions (< <> > etc.) work also with string constants ('string') and string - | variables and are not case sensitive then. - | - | The precedence of the operands is little different from Pascal (Delphi), giving - | a lower precedence to logical operands, as these only act on Booleans - | (and not on integers like in Pascal) - | - | 1 (highest): ! -x +x % - | 2: ^ - | 3: * / div mod - | 4: + - - | 5: > >= < <= <> = - | 6: not - | 7: or and xor - | 8: (lowest): := - | - | This precedence order is easily customizable by overriding/changing - | FillExpressList (the precedence order is defined there) - | - | You can use user-defined variables in the expressions and also assign to - | variables using the := operand - | - | The use of this object is very simple, therefore it doesn't seem necessary - | to make a non-visual component of it. - | - | NEW IN VERSION 1.1: - | Optimization, increasing the efficiency for evaluating an expression many times - | (with a variable in the expression). - | The 'compiler' then removes constant expressions and replaces - | these with the evaluated result. - | e.g. 4*4*x becomes 16*x - | ln(5)+3*x becomes 1.609437912+3*x - | limitation: - | 4*x+3+3+5 evaluates as 4*x+3+3+5 (due to precedence rules) - | whereas: - | 4*x+(3+3+5) becomes 4*x+11 (use brackets to be sure that constant - | expressions are removed by the compiler) - | If optimization is possible, the code is often faster than compiled - | Delphi code. - | - | Hexadecimal notation supported: $FF is converted to 255 - | the Hexadecimals characted ($) is adjustable by setting the HexChar - | property - | - | The variable DecimalSeparator (SysUtils) now determines the - | decimal separator (propery DecimSeparator). If the decimal separator - | is a comma then the function argument separator is a semicolon ';' - | - | 'in' operator for strings added (John Bultena): - | 'a' in 'dasad,sdsd,a,sds' evaluates True - | 's' in 'dasad,sdsd,a,sds' evaluates False - | - | NEW IN VERSION 1.2: - | More flexible string functions (still only from string-> double) - | - | Possibility to return NaN (not a number = 0/0) - | instead of math exceptions (see: NAN directive) - | using this option makes the evaluator somewhat slower - | - |--------------------------------------------------------------- } -interface - -{ .$DEFINE NAN } -{ use this directive to suppress math exceptions, - instead NAN is returned. - Note that using this directive is less efficient } - -uses OObjects, Classes, ParseClass; - -type - - TCustomExpressionParser = class - private - FHexChar: Char; - FDecimSeparator: Char; // default SysUtils.DecimalSeparator - FArgSeparator: Char; // default SysUtils.ListSeparator - FOptimize: Boolean; - ConstantsList: TOCollection; - LastRec: PExpressionRec; - CurrentRec: PExpressionRec; - function ParseString(AnExpression: string): TExprCollection; - function MakeTree(var Expr: TExprCollection): PExpressionRec; - function MakeRec: PExpressionRec; - function MakeLinkedList(ExprRec: PExpressionRec): PDouble; - function CompileExpression(AnExpression: string): Boolean; - function isBoolean: Boolean; - procedure Check(AnExprList: TExprCollection); - function CheckArguments(ExprRec: PExpressionRec): Boolean; - procedure DisposeTree(ExprRec: PExpressionRec); - function EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; - function EvaluateList(ARec: PExpressionRec): Double; - function RemoveConstants(ExprRec: PExpressionRec): PExpressionRec; - function ResultCanVary(ExprRec: PExpressionRec): Boolean; - procedure DisposeList(ARec: PExpressionRec); - procedure SetArgSeparator(const Value: Char); - procedure SetDecimSeparator(const Value: Char); - protected - WordsList: TSortedCollection; - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); virtual; - procedure FillExpressList; virtual; abstract; - function CurrentExpression: string; virtual; abstract; - public - constructor Create; - destructor Destroy; override; - procedure AddReplaceExprWord(AExprWord: TExprWord); - procedure DefineVariable(AVarName: string; AValue: PDouble); - procedure DefineStringVariable(AVarName: string; AValue: PString); - procedure DefineFunction(AFunctName, ADescription: string; - AFuncAddress: TDoubleFunc; NArguments: Integer); - procedure DefineStringFunction(AFunctName, ADescription: string; - AFuncAddress: TStringFunc); - procedure ReplaceFunction(OldName: string; AFunction: TObject); - function Evaluate(AnExpression: string): Double; - function EvaluateCurrent: Double; // fastest - function AddExpression(AnExpression: string): Integer; virtual; - procedure ClearExpressions; virtual; - procedure GetGeneratedVars(AList: TList); - procedure GetFunctionNames(AList: TStrings); - function GetFunctionDescription(AFunction: string): string; - property HexChar: Char read FHexChar write FHexChar; - property ArgSeparator: Char read FArgSeparator write SetArgSeparator; - property DecimSeparator: Char read FDecimSeparator write SetDecimSeparator; - property Optimize: Boolean read FOptimize write FOptimize; - // if optimize is selected, constant expressions are tried to remove - // such as: 4*4*x is evaluated as 16*x and exp(1)-4*x is repaced by 2.17 -4*x - end; - - TExpressionParser = class(TCustomExpressionParser) - private - Expressions: TStringList; - FCurrentIndex: Integer; - function GetResults(AIndex: Integer): Double; - function GetAsString(AIndex: Integer): string; - function GetAsBoolean(AIndex: Integer): Boolean; - function GetExprSize(AIndex: Integer): Integer; - function GetAsHexadecimal(AIndex: Integer): string; - function GetExpression(AIndex: Integer): string; - protected - procedure ReplaceExprWord(OldExprWord, NewExprWord: TExprWord); override; - procedure FillExpressList; override; - function CurrentExpression: string; override; - public - constructor Create; - destructor Destroy; override; - function AddExpression(AnExpression: string): Integer; override; - procedure ClearExpressions; override; - property ExpressionSize[AIndex: Integer]: Integer read GetExprSize; - property Expression[AIndex: Integer]: string read GetExpression; - property AsFloat[AIndex: Integer]: Double read GetResults; - property AsString[AIndex: Integer]: string read GetAsString; - property AsBoolean[AIndex: Integer]: Boolean read GetAsBoolean; - property AsHexadecimal[AIndex: Integer]: string read GetAsHexadecimal; - property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex; - end; - - { ------------------------------------------------------------------ - Example of creating a user-defined Parser, - here are Pascal operators replaced by C++ style, - note that sometimes the ParseString function needs to be changed, - if you define new operators (characters). - Also some special checks do not work: like 'not not x' should be - replaced by 'x', but this does not work with !!x (c style) - -------------------------------------------------------------------- } - TCStyleParser = class(TExpressionParser) - FCStyle: Boolean; - private - procedure SetCStyle(const Value: Boolean); - protected - procedure FillExpressList; override; - public - property CStyle: Boolean read FCStyle write SetCStyle; - end; - -implementation - -uses Math, SysUtils; - -const - errorPrefix = 'Error in math expression: '; - -procedure _Power(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Power(Args[0]^, Args[1]^); -end; - -function _Pos(str1, str2: string): Double; -begin - result := pos(str1, str2); -end; - -procedure _IntPower(Param: PExpressionRec); -begin - with Param^ do - Res := IntPower(Args[0]^, Round(Args[1]^)); -end; - -procedure _ArcCos(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCos(Args[0]^); -end; - -procedure _ArcSin(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSin(Args[0]^); -end; - -procedure _ArcSinh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcSinh(Args[0]^); -end; - -procedure _ArcCosh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcCosh(Args[0]^); -end; - -procedure _ArcTanh(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTanh(Args[0]^); -end; - -procedure _ArcTan2(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan2(Args[0]^, Args[1]^); -end; - -procedure _arctan(Param: PExpressionRec); -begin - with Param^ do - Res := ArcTan(Args[0]^); -end; - -procedure _Cosh(Param: PExpressionRec); -begin - with Param^ do - Res := Cosh(Args[0]^); -end; - -procedure _tanh(Param: PExpressionRec); -begin - with Param^ do - Res := Tanh(Args[0]^); -end; - -procedure _Sinh(Param: PExpressionRec); -begin - with Param^ do - Res := Sinh(Args[0]^); -end; - -procedure _DegToRad(Param: PExpressionRec); -begin - with Param^ do - Res := DegToRad(Args[0]^); -end; - -procedure _RadToDeg(Param: PExpressionRec); -begin - with Param^ do - Res := RadToDeg(Args[0]^); -end; - -procedure _ln(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Ln(Args[0]^); -end; - -procedure _log10(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := Log10(Args[0]^); -end; - -procedure _logN(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF} - Res := LogN(Args[0]^, Args[1]^); -end; - -procedure _negate(Param: PExpressionRec); -begin - with Param^ do - Res := -Args[0]^; -end; - -procedure _plus(Param: PExpressionRec); -begin - with Param^ do - Res := +Args[0]^; -end; - -procedure _exp(Param: PExpressionRec); -begin - with Param^ do - Res := Exp(Args[0]^); -end; - -procedure _sin(Param: PExpressionRec); -begin - with Param^ do - Res := Sin(Args[0]^); -end; - -procedure _Cos(Param: PExpressionRec); -begin - with Param^ do - Res := Cos(Args[0]^); -end; - -procedure _tan(Param: PExpressionRec); -begin - with Param^ do - Res := Tan(Args[0]^); -end; - -procedure _Add(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ + Args[1]^; -end; - -procedure _Assign(Param: PExpressionRec); -begin - with Param^ do - begin - Res := Args[1]^; - Args[0]^ := Args[1]^; - end; -end; - -procedure _mult(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * Args[1]^; -end; - -procedure _minus(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ - Args[1]^; -end; - -procedure _realDivide(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Abs(Args[1]^) < 1E-30 then - Res := Nan - else -{$ENDIF} - Res := Args[0]^ / Args[1]^; -end; - -procedure _Div(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) div Round(Args[1]^); -end; - -procedure _mod(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Round(Args[1]^) = 0 then - Res := Nan - else -{$ENDIF} - Res := Round(Args[0]^) mod Round(Args[1]^); -end; - -// procedure _pi(Param: PExpressionRec); -// begin -// with Param^ do -// Res := Pi; -// end; - -procedure _random(Param: PExpressionRec); -begin - with Param^ do - Res := Random; -end; - -procedure _randG(Param: PExpressionRec); -begin - with Param^ do - Res := RandG(Args[0]^, Args[1]^); -end; - -procedure _gt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ > Args[1]^); -end; - -procedure _ge(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ + 1E-30 >= Args[1]^); -end; - -procedure _lt(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ < Args[1]^); -end; - -procedure _eq(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) < 1E-30); -end; - -procedure _ne(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Abs(Args[0]^ - Args[1]^) > 1E-30); -end; - -procedure _le(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(Args[0]^ <= Args[1]^ + 1E-30); -end; - -procedure _if(Param: PExpressionRec); -begin - with Param^ do - if Boolean(Round(Args[0]^)) then - Res := Args[1]^ - else - Res := Args[2]^; -end; - -procedure _And(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) and Round(Args[1]^); -end; - -procedure _shl(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shl Round(Args[1]^); -end; - -procedure _shr(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) shr Round(Args[1]^); -end; - -procedure _or(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) or Round(Args[1]^); -end; - -procedure _not(Param: PExpressionRec); -var - b: Integer; -begin - with Param^ do - begin - b := Round(Args[0]^); - Res := Byte(not Boolean(b)); - end; -end; - -procedure _xor(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^) xor Round(Args[1]^); -end; - -procedure _round(Param: PExpressionRec); -begin - with Param^ do - Res := Round(Args[0]^); -end; - -procedure _trunc(Param: PExpressionRec); -begin - with Param^ do - Res := Trunc(Args[0]^); -end; - -procedure _sqrt(Param: PExpressionRec); -begin - with Param^ do -{$IFDEF NAN} - if Args[0]^ < 0 then - Res := Nan - else -{$ENDIF}Res := Sqrt(Args[0]^); -end; - -procedure _Percentage(Param: PExpressionRec); -begin - with Param^ do - Res := Args[0]^ * 0.01; -end; - -procedure _factorial(Param: PExpressionRec); - function Factorial(X: Extended): Extended; - begin - if X <= 1.1 then - result := 1 - else - result := X * Factorial(X - 1); - end; - -begin - with Param^ do - Res := Factorial(Round(Args[0]^)); -end; - -procedure _sqr(Param: PExpressionRec); -begin - with Param^ do - Res := Sqr(Args[0]^); -end; - -procedure _Abs(Param: PExpressionRec); -begin - with Param^ do - Res := Abs(Args[0]^); -end; - -procedure _max(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ < Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _min(Param: PExpressionRec); -begin - with Param^ do - if Args[0]^ > Args[1]^ then - Res := Args[1]^ - else - Res := Args[0]^ -end; - -procedure _Add1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ + 1; - Res := Args[0]^; - end; -end; - -procedure _minus1(Param: PExpressionRec); -begin - with Param^ do - begin - Args[0]^ := Args[0]^ - 1; - Res := Args[0]^; - end; -end; - -procedure _isNaN(Param: PExpressionRec); -begin - with Param^ do - Res := Byte(isNan(Args[0]^)); -end; - -{ TCustomExpressionParser } - -function TCustomExpressionParser.CompileExpression(AnExpression - : string): Boolean; -var - ExpColl: TExprCollection; - ExprTree: PExpressionRec; -begin - ExprTree := nil; - ExpColl := nil; - try - // FCurrentExpression := anExpression; - ExpColl := ParseString(LowerCase(AnExpression)); - Check(ExpColl); - ExprTree := MakeTree(ExpColl); - CurrentRec := nil; - if CheckArguments(ExprTree) then - begin - if Optimize then - try - ExprTree := RemoveConstants(ExprTree); - except - on EMathError do - begin - ExprTree := nil; - raise; - end; - end; - // all constant expressions are evaluated and replaced by variables - if ExprTree.ExprWord.isVariable then - CurrentRec := ExprTree - else - MakeLinkedList(ExprTree); - end - else - raise EParserException.Create - (errorPrefix + - 'Syntax error: function or operand has too few arguments'); - except - ExpColl.Free; - DisposeTree(ExprTree); - raise; - end; - result := True; -end; - -constructor TCustomExpressionParser.Create; -begin - FDecimSeparator := FormatSettings.DecimalSeparator; - FArgSeparator := FormatSettings.ListSeparator; - HexChar := '$'; - WordsList := TExpressList.Create(30); - ConstantsList := TOCollection.Create(10); - Optimize := True; - FillExpressList; -end; - -destructor TCustomExpressionParser.Destroy; -begin - inherited; - WordsList.Free; - ConstantsList.Free; - ClearExpressions; -end; - -function TCustomExpressionParser.CheckArguments - (ExprRec: PExpressionRec): Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := True; - for I := 0 to ExprWord.NFunctionArg - 1 do - if Args[I] = nil then - begin - result := False; - Exit; - end - else - begin - result := CheckArguments(ArgList[I]); - if not result then - Exit; - end; - end; -end; - -function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec) - : Boolean; -var - I: Integer; -begin - with ExprRec^ do - begin - result := ExprWord.CanVary; - if not result then - for I := 0 to ExprWord.NFunctionArg - 1 do - if ResultCanVary(ArgList[I]) then - begin - result := True; - Exit; - end - end; -end; - -function TCustomExpressionParser.RemoveConstants(ExprRec: PExpressionRec) - : PExpressionRec; -var - I: Integer; - isBool: Boolean; - D: Double; -begin - result := ExprRec; - with ExprRec^ do - begin - if not ResultCanVary(ExprRec) then - begin - if not ExprWord.isVariable then - begin - D := EvaluateDisposeTree(ExprRec, isBool); - result := MakeRec; - if isBool then - result.ExprWord := TBooleanConstant.CreateAsDouble('', D) - else - result.ExprWord := TDoubleConstant.CreateAsDouble('', D); - // TDoubleConstant(Result.ExprWord).Value := D; - result.Oper := result.ExprWord.DoubleFunc; - result.Args[0] := result.ExprWord.AsPointer; - ConstantsList.Add(result.ExprWord); - end; - end - else - for I := 0 to ExprWord.NFunctionArg - 1 do - ArgList[I] := RemoveConstants(ArgList[I]); - end; -end; - -procedure TCustomExpressionParser.DisposeTree(ExprRec: PExpressionRec); -var - I: Integer; -begin - if ExprRec <> nil then - with ExprRec^ do - begin - if ExprWord <> nil then - for I := 0 to ExprWord.NFunctionArg - 1 do - DisposeTree(ArgList[I]); - Dispose(ExprRec); - end; -end; - -function TCustomExpressionParser.EvaluateDisposeTree(ExprRec: PExpressionRec; - var isBool: Boolean): Double; -begin - if ExprRec.ExprWord.isVariable then - CurrentRec := ExprRec - else - MakeLinkedList(ExprRec); - isBool := isBoolean; - try - result := EvaluateList(CurrentRec); - finally - DisposeList(CurrentRec); - CurrentRec := nil; - end; -end; - -function TCustomExpressionParser.MakeLinkedList - (ExprRec: PExpressionRec): PDouble; -var - I: Integer; -begin - with ExprRec^ do - begin - for I := 0 to ExprWord.NFunctionArg - 1 do - Args[I] := MakeLinkedList(ArgList[I]); - if ExprWord.isVariable { @Oper = @_Variable } then - begin - result := Args[0]; - Dispose(ExprRec); - end - else - begin - result := @Res; - if CurrentRec = nil then - begin - CurrentRec := ExprRec; - LastRec := ExprRec; - end - else - begin - LastRec.Next := ExprRec; - LastRec := ExprRec; - end; - end; - end; -end; - -function TCustomExpressionParser.MakeTree(var Expr: TExprCollection) - : PExpressionRec; -{ This is the most complex routine, it breaks down the expression and makes - a linked tree which is used for fast function evaluations - it is implemented recursively } -var - I, IArg, IStart, IEnd, brCount: Integer; - FirstOper: TExprWord; - Expr2: TExprCollection; - Rec: PExpressionRec; -begin - FirstOper := nil; - IStart := 0; - try - result := nil; - repeat - Rec := MakeRec; - if result <> nil then - begin - IArg := 1; - Rec.ArgList[0] := result; - end - else - IArg := 0; - result := Rec; - Expr.EraseExtraBrackets; - if Expr.Count = 1 then - begin - result.ExprWord := TExprWord(Expr.Items[0]); - result.Oper := @result.ExprWord.DoubleFunc; - if not result.ExprWord.isVariable then - result.Oper := @result.ExprWord.DoubleFunc - else - begin - result.Args[0] := result.ExprWord.AsPointer; - end; - Exit; - end; - IEnd := Expr.NextOper(IStart); - if IEnd = Expr.Count then - raise EParserException.Create - (errorPrefix + 'Syntax error in expression ' + CurrentExpression); - if TExprWord(Expr.Items[IEnd]).NFunctionArg > 0 then - begin - FirstOper := TExprWord(Expr.Items[IEnd]); - result.ExprWord := FirstOper; - result.Oper := FirstOper.DoubleFunc; - end - else - raise EParserException.Create - (errorPrefix + 'Can not find operand/function'); - if not FirstOper.IsOper then - begin // parse function arguments - IArg := 0; - IStart := IEnd + 1; - IEnd := IStart; - if TExprWord(Expr.Items[IEnd]).VarType = vtLeftBracket then - brCount := 1 - else - brCount := 0; - while (IEnd < Expr.Count - 1) and (brCount <> 0) do - begin - Inc(IEnd); - case TExprWord(Expr.Items[IEnd]).VarType of - vtLeftBracket: - Inc(brCount); - vtComma: - if brCount = 1 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - IStart := IEnd; - end; - vtRightBracket: - Dec(brCount); - end; - end; - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := IStart + 1 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end - else if IEnd - IStart > 0 then - begin - Expr2 := TExprCollection.Create(IEnd - IStart + 1); - for I := 0 to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - Inc(IArg); - end; - IStart := IEnd + 1; - IEnd := IStart - 1; - repeat - IEnd := Expr.NextOper(IEnd + 1); - until (IEnd >= Expr.Count) or - (TFunction(Expr.Items[IEnd]).OperPrec >= TFunction(FirstOper).OperPrec); - if IEnd <> IStart then - begin - Expr2 := TExprCollection.Create(IEnd); - for I := IStart to IEnd - 1 do - Expr2.Add(Expr.Items[I]); - result.ArgList[IArg] := MakeTree(Expr2); - end; - IStart := IEnd; - until IEnd >= Expr.Count; - finally - Expr.Free; - Expr := nil; - end; -end; - -function TCustomExpressionParser.ParseString(AnExpression: string) - : TExprCollection; -var - isConstant: Boolean; - I, I1, I2, Len: Integer; - W, S: string; - Word: TExprWord; - OldDecim: Char; - procedure ReadConstant(AnExpr: string; isHex: Boolean); - begin - isConstant := True; - while (I2 <= Len) and ((AnExpr[I2] in ['0' .. '9']) or - (isHex and (AnExpr[I2] in ['a' .. 'f']))) do - Inc(I2); - if I2 <= Len then - begin - if AnExpr[I2] = DecimSeparator then - begin - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - if (I2 <= Len) and (AnExpr[I2] = 'e') then - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] in ['+', '-']) then - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] in ['0' .. '9']) do - Inc(I2); - end; - end; - end; - procedure ReadWord(AnExpr: string); - var - OldI2: Integer; - begin - isConstant := False; - I1 := I2; - while (I1 < Len) and (AnExpr[I1] = ' ') do - Inc(I1); - I2 := I1; - if I1 <= Len then - begin - if AnExpr[I2] = HexChar then - begin - Inc(I2); - OldI2 := I2; - ReadConstant(AnExpr, True); - if I2 = OldI2 then - begin - isConstant := False; - while (I2 <= Len) and (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - end - else if AnExpr[I2] = DecimSeparator then - ReadConstant(AnExpr, False) - else - case AnExpr[I2] of - '''': - begin - isConstant := True; - Inc(I2); - while (I2 <= Len) and (AnExpr[I2] <> '''') do - Inc(I2); - if I2 <= Len then - Inc(I2); - end; - 'a' .. 'z', '_': - begin - while (I2 <= Len) and - (AnExpr[I2] in ['a' .. 'z', '_', '0' .. '9']) do - Inc(I2); - end; - '>', '<': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['=', '<', '>'] then - Inc(I2); - end; - '=': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['<', '>', '='] then - Inc(I2); - end; - '&': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['&'] then - Inc(I2); - end; - '|': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] in ['|'] then - Inc(I2); - end; - ':': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then - Inc(I2); - end; - '!': - begin - if (I2 <= Len) then - Inc(I2); - if AnExpr[I2] = '=' then // support for != - Inc(I2); - end; - '+': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '+') and - WordsList.Search(pchar('++'), I) then - Inc(I2); - end; - '-': - begin - Inc(I2); - if (I2 <= Len) and (AnExpr[I2] = '-') and - WordsList.Search(pchar('--'), I) then - Inc(I2); - end; - '^', '/', '\', '*', '(', ')', '%', '~', '$': - Inc(I2); - '0' .. '9': - ReadConstant(AnExpr, False); - else - begin - Inc(I2); - end; - end; - end; - end; - -begin - OldDecim := FormatSettings.DecimalSeparator; - FormatSettings.DecimalSeparator := DecimSeparator; - result := TExprCollection.Create(10); - I2 := 1; - S := Trim(LowerCase(AnExpression)); - Len := Length(S); - repeat - ReadWord(S); - W := Trim(Copy(S, I1, I2 - I1)); - if isConstant then - begin - if W[1] = HexChar then - begin - W[1] := '$'; - W := IntToStr(StrToInt(W)); - end; - if W[1] = '''' then - Word := TStringConstant.Create(W) - else - Word := TDoubleConstant.Create(W, W); - result.Add(Word); - ConstantsList.Add(Word); - end - else if W <> '' then - if WordsList.Search(pchar(W), I) then - result.Add(WordsList.Items[I]) - else - begin - Word := TGeneratedVariable.Create(W); - result.Add(Word); - WordsList.Add(Word); - end; - until I2 > Len; - FormatSettings.DecimalSeparator := OldDecim; -end; - -procedure TCustomExpressionParser.Check(AnExprList: TExprCollection); - -var - I, J, K, L: Integer; - Word: TSimpleStringFunction; - function GetStringFunction(ExprWord, Left, Right: TExprWord) - : TSimpleStringFunction; - begin - with TSimpleStringFunction(ExprWord) do - if CanVary then - result := TVaryingStringFunction.Create(Name, Description, StringFunc, - Left, Right) - else - result := TSimpleStringFunction.Create(Name, Description, StringFunc, - Left, Right); - end; - -begin - AnExprList.Check; - with AnExprList do - begin - I := 0; - while I < Count do - begin - { ----CHECK ON DOUBLE MINUS OR DOUBLE PLUS---- } - if ((TExprWord(Items[I]).Name = '-') or (TExprWord(Items[I]).Name = '+')) - and ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtComma) or - (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I - 1]).IsOper and (TExprWord(Items[I - 1]) - .NFunctionArg = 2))) then - begin - { replace e.g. ----1 with +1 } - if TExprWord(Items[I]).Name = '-' then - K := -1 - else - K := 1; - L := 1; - while (I + L < Count) and ((TExprWord(Items[I + L]).Name = '-') or - (TExprWord(Items[I + L]).Name = '+')) and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtComma) or - (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) or - (TExprWord(Items[I + L - 1]).IsOper and (TExprWord(Items[I + L - 1]) - .NFunctionArg = 2))) do - begin - if TExprWord(Items[I + L]).Name = '-' then - K := -1 * K; - Inc(L); - end; - if L > 0 then - begin - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end; - if K = -1 then - begin - if WordsList.Search(pchar('-@'), J) then - Items[I] := WordsList.Items[J]; - end - else if WordsList.Search(pchar('+@'), J) then - Items[I] := WordsList.Items[J]; - end; - { ----CHECK ON DOUBLE NOT---- } - if (TExprWord(Items[I]).Name = 'not') and - ((I = 0) or (TExprWord(Items[I - 1]).VarType = vtLeftBracket) or - TExprWord(Items[I - 1]).IsOper) then - begin - { replace e.g. not not 1 with 1 } - K := -1; - L := 1; - while (I + L < Count) and (TExprWord(Items[I + L]).Name = 'not') and - ((I + L = 0) or (TExprWord(Items[I + L - 1]).VarType = vtLeftBracket) - or TExprWord(Items[I + L - 1]).IsOper) do - begin - K := -K; - Inc(L); - end; - if L > 0 then - begin - if K = 1 then - begin // remove all - for J := I to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - else - begin // keep one - Dec(L); - for J := I + 1 to Count - 1 - L do - Items[J] := Items[J + L]; - Count := Count - L; - end - end; - end; - { -----MISC CHECKS----- } - if (TExprWord(Items[I]).isVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' two space limited variables/constants'); - if (TExprWord(Items[I]).ClassType = TGeneratedVariable) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create(errorPrefix + TExprWord(Items[I]).Name + - ' is an unknown function'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I >= Count - 1) or (TExprWord(Items[I + 1]).VarType = vtRightBracket)) - then - raise EParserException.Create(errorPrefix + 'Empty brackets ()'); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).VarType = vtLeftBracket)) - then - raise EParserException.Create - (errorPrefix + 'Missing operand between )('); - if (TExprWord(Items[I]).VarType = vtRightBracket) and - ((I < Count - 1) and (TExprWord(Items[I + 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between ) and constant/variable'); - if (TExprWord(Items[I]).VarType = vtLeftBracket) and - ((I > 0) and (TExprWord(Items[I - 1]).isVariable)) then - raise EParserException.Create - (errorPrefix + 'Missing operand between constant/variable and ('); - - { -----CHECK ON INTPOWER------ } - if (TExprWord(Items[I]).Name = '^') and - ((I < Count - 1) and (TExprWord(Items[I + 1]) - .ClassType = TDoubleConstant) and - (pos(DecimSeparator, TExprWord(Items[I + 1]).Name) = 0)) then - if WordsList.Search(pchar('^@'), J) then - Items[I] := WordsList.Items[J]; // use the faster intPower if possible - Inc(I); - end; - - { -----CHECK STRING COMPARE-------- } - I := Count - 2; - while I >= 0 do - begin - if (TExprWord(Items[I]).VarType = vtString) then - begin - if (I >= 2) and (TExprWord(Items[I - 2]) is TSimpleStringFunction) then - begin - if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I - 2] := Word; - for J := I - 1 to Count - 6 do - Items[J] := Items[J + 5]; - Count := Count - 5; - I := I - 1; - ConstantsList.Add(Word); - end - else - begin - with TSimpleStringFunction(Items[I - 2]) do - Word := GetStringFunction(TExprWord(Items[I - 2]), - TExprWord(Items[I]), nil); - Items[I - 2] := Word; - for J := I - 1 to Count - 4 do - Items[J] := Items[J + 3]; - Count := Count - 3; - I := I - 1; - ConstantsList.Add(Word); - end; - end - else if (I + 2 < Count) and (TExprWord(Items[I + 2]).VarType = vtString) - then - begin - Word := TLogicalStringOper.Create(TExprWord(Items[I + 1]).Name, - TExprWord(Items[I]), TExprWord(Items[I + 2])); - Items[I] := Word; - for J := I + 1 to Count - 3 do - Items[J] := Items[J + 2]; - Count := Count - 2; - ConstantsList.Add(Word); - end; - end; - Dec(I); - end; - end; -end; - -{$IFDEF NAN} - -function HasNaN(LastRec1: PExpressionRec): Boolean; -var - I: Integer; -begin - result := False; - for I := 0 to LastRec1^.ExprWord.NFunctionArg - 1 do - if (comp(LastRec1^.Args[I]^) = comp(Nan)) - // much faster than CompareMem(LastRec1^.Args[I], @Nan, SizeOf(Double)) - and (@LastRec1^.ExprWord.DoubleFunc <> @_isNaN) and - (@LastRec1^.ExprWord.DoubleFunc <> @_Assign) then - begin - result := True; - Exit; - end; -end; -{$ENDIF} - -function TCustomExpressionParser.EvaluateList(ARec: PExpressionRec): Double; -var - LastRec1: PExpressionRec; -begin - if ARec <> nil then - begin - LastRec1 := ARec; - while LastRec1^.Next <> nil do - begin -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - LastRec1 := LastRec1^.Next; - end; -{$IFDEF NAN} - if HasNaN(LastRec1) then - LastRec1^.Res := Nan - else -{$ENDIF} - LastRec1^.Oper(LastRec1); - result := LastRec1^.Res; - end - else - result := Nan; -end; - -procedure TCustomExpressionParser.DefineFunction(AFunctName, - ADescription: string; AFuncAddress: TDoubleFunc; NArguments: Integer); -begin - AddReplaceExprWord(TFunction.Create(AFunctName, ADescription, AFuncAddress, - NArguments)); -end; - -procedure TCustomExpressionParser.DefineVariable(AVarName: string; - AValue: PDouble); -begin - AddReplaceExprWord(TDoubleVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.DefineStringVariable(AVarName: string; - AValue: PString); -begin - AddReplaceExprWord(TStringVariable.Create(AVarName, AValue)); -end; - -procedure TCustomExpressionParser.GetGeneratedVars(AList: TList); -var - I: Integer; -begin - AList.Clear; - with WordsList do - for I := 0 to Count - 1 do - begin - if TObject(Items[I]).ClassType = TGeneratedVariable then - AList.Add(Items[I]); - end; -end; - -function TCustomExpressionParser.isBoolean: Boolean; -var - LastRec1: PExpressionRec; -begin - if CurrentRec = nil then - result := False - else - begin - LastRec1 := CurrentRec; - // LAST operand should be boolean -otherwise If(,,) doesn't work - while (LastRec1^.Next <> nil) do - LastRec1 := LastRec1^.Next; - result := (LastRec1.ExprWord <> nil) and - (LastRec1.ExprWord.VarType = vtBoolean); - end; -end; - -procedure TCustomExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - J: Integer; - Rec: PExpressionRec; - p, pnew: pointer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - p := OldExprWord.AsPointer; - pnew := NewExprWord.AsPointer; - Rec := CurrentRec; - repeat - if (Rec.ExprWord = OldExprWord) then - begin - Rec.ExprWord := NewExprWord; - Rec.Oper := NewExprWord.DoubleFunc; - end; - if p <> nil then - for J := 0 to Rec.ExprWord.NFunctionArg - 1 do - if Rec.Args[J] = p then - Rec.Args[J] := pnew; - Rec := Rec.Next; - until Rec = nil; -end; - -function TCustomExpressionParser.MakeRec: PExpressionRec; -var - I: Integer; -begin - result := New(PExpressionRec); - result.Oper := nil; - for I := 0 to MaxArg - 1 do - result.ArgList[I] := nil; - result.Res := 0; - result.Next := nil; - result.ExprWord := nil; -end; - -function TCustomExpressionParser.Evaluate(AnExpression: string): Double; -begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TCustomExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := 0; - CompileExpression(AnExpression); - end - else - result := -1; -end; - -procedure TCustomExpressionParser.ReplaceFunction(OldName: string; - AFunction: TObject); -var - I: Integer; -begin - if WordsList.Search(pchar(OldName), I) then - begin - ReplaceExprWord(WordsList.Items[I], TExprWord(AFunction)); - WordsList.AtFree(I); - end; - if AFunction <> nil then - WordsList.Add(AFunction); -end; - -procedure TCustomExpressionParser.ClearExpressions; -begin - DisposeList(CurrentRec); - LastRec := nil; -end; - -procedure TCustomExpressionParser.DisposeList(ARec: PExpressionRec); -var - TheNext: PExpressionRec; -begin - if ARec <> nil then - repeat - TheNext := ARec.Next; - Dispose(ARec); - ARec := TheNext; - until ARec = nil; -end; - -function TCustomExpressionParser.EvaluateCurrent: Double; -begin - result := EvaluateList(CurrentRec); -end; - -procedure TCustomExpressionParser.AddReplaceExprWord(AExprWord: TExprWord); -var - IOldVar: Integer; -begin - if WordsList.Search(pchar(AExprWord.Name), IOldVar) then - begin - ReplaceExprWord(WordsList.Items[IOldVar], AExprWord); - WordsList.AtFree(IOldVar); - WordsList.Add(AExprWord); - end - else - WordsList.Add(AExprWord); -end; - -function TCustomExpressionParser.GetFunctionDescription - (AFunction: string): string; -var - S: string; - p, I: Integer; -begin - S := AFunction; - p := pos('(', S); - if p > 0 then - S := Copy(S, 1, p - 1); - if WordsList.Search(pchar(S), I) then - result := TExprWord(WordsList.Items[I]).Description - else - result := ''; -end; - -procedure TCustomExpressionParser.GetFunctionNames(AList: TStrings); -var - I, J: Integer; - S: string; -begin - with WordsList do - for I := 0 to Count - 1 do - with TExprWord(WordsList.Items[I]) do - if Description <> '' then - begin - S := Name; - if NFunctionArg > 0 then - begin - S := S + '('; - for J := 0 to NFunctionArg - 2 do - S := S + ArgSeparator; - S := S + ')'; - end; - AList.Add(S); - end; -end; - -procedure TCustomExpressionParser.DefineStringFunction(AFunctName, - ADescription: string; AFuncAddress: TStringFunc); -begin - AddReplaceExprWord(TSimpleStringFunction.Create(AFunctName, ADescription, - AFuncAddress, nil, nil)); -end; - -procedure TCustomExpressionParser.SetArgSeparator(const Value: Char); -begin - ReplaceFunction(FArgSeparator, TComma.Create(Value, nil)); - FArgSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - DecimSeparator := '.' - else - DecimSeparator := ','; - end; - -end; - -procedure TCustomExpressionParser.SetDecimSeparator(const Value: Char); -begin - FDecimSeparator := Value; - if (DecimSeparator = ArgSeparator) then - begin - if DecimSeparator = ',' then - ArgSeparator := ';' - else - ArgSeparator := ','; - end; -end; - -{ TExpressionParser } - -procedure TExpressionParser.ClearExpressions; -var - I: Integer; -begin - for I := 0 to Expressions.Count - 1 do - DisposeList(PExpressionRec(Expressions.Objects[I])); - Expressions.Clear; - CurrentIndex := -1; - CurrentRec := nil; - LastRec := nil; -end; - -{ function TExpressionParser.Evaluate(AnExpression: string): Double; - begin - if AnExpression <> '' then - begin - AddExpression(AnExpression); - Result := EvaluateList(CurrentRec); - end - else - Result := Nan; - end; -} - -function TExpressionParser.AddExpression(AnExpression: string): Integer; -begin - if AnExpression <> '' then - begin - result := Expressions.IndexOf(AnExpression); - if (result < 0) and CompileExpression(AnExpression) then - result := Expressions.AddObject(AnExpression, TObject(CurrentRec)) - else - CurrentRec := PExpressionRec(Expressions.Objects[result]); - end - else - result := -1; - CurrentIndex := result; -end; - -function TExpressionParser.GetResults(AIndex: Integer): Double; -begin - if AIndex >= 0 then - begin - CurrentRec := PExpressionRec(Expressions.Objects[AIndex]); - result := EvaluateList(CurrentRec); - end - else - result := Nan; -end; - -function TExpressionParser.GetAsBoolean(AIndex: Integer): Boolean; -var - D: Double; -begin - D := AsFloat[AIndex]; - if not isBoolean then - raise EParserException.Create(errorPrefix + 'Expression is not boolean') - else if (D < 0.1) and (D > -0.1) then - result := False - else - result := True; -end; - -function TExpressionParser.GetAsString(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - if isBoolean then - begin -{$IFDEF nan} - if isNan(D) then - result := 'NAN' - else -{$ENDIF} if (D < 0.1) and (D > -0.1) then - result := 'False' - else if (D > 0.9) and (D < 1.1) then - result := 'True' - else - result := Format('%.10g', [D]); - end - else - result := Format('%.10g', [D]); -end; - -constructor TExpressionParser.Create; -begin - inherited; - Expressions := TStringList.Create; - Expressions.Sorted := False; -end; - -destructor TExpressionParser.Destroy; -begin - inherited; - Expressions.Free; -end; - -procedure TExpressionParser.FillExpressList; -begin - with WordsList do - begin - Add(TLeftBracket.Create('(', nil)); - Add(TRightBracket.Create(')', nil)); - Add(TComma.Create(ArgSeparator, nil)); - Add(TConstant.CreateAsDouble('pi', 'pi = 3.1415926535897932385', Pi)); -{$IFDEF NAN} - Add(TConstant.CreateAsDouble('nan', - 'Not a number, mathematical error in result', Nan)); - Add(TBooleanFunction.Create('isnan', 'Is Not a Number (has error)?', - _isNaN, 1)); -{$ENDIF} - Add(TVaryingFunction.Create('random', 'random number between 0 and 1', - _random, 0)); - // definitions of operands: - // the last number is used to determine the precedence - Add(TFunction.CreateOper('!', _factorial, 1, True { isOperand } , - 10 { precedence } )); - Add(TFunction.CreateOper('++', _Add1, 1, True, 5)); - Add(TFunction.CreateOper('--', _minus1, 1, True, 5)); - Add(TFunction.CreateOper('%', _Percentage, 1, True, 10)); - Add(TFunction.CreateOper('-@', _negate, 1, True, 10)); - Add(TFunction.CreateOper('+@', _plus, 1, True, 10)); - Add(TFunction.CreateOper('^', _Power, 2, True, 20)); - Add(TFunction.CreateOper('^@', _IntPower, 2, True, 20)); - Add(TFunction.CreateOper('*', _mult, 2, True, 30)); - Add(TFunction.CreateOper('/', _realDivide, 2, True, 30)); - Add(TFunction.CreateOper('div', _Div, 2, True, 30)); - Add(TFunction.CreateOper('mod', _mod, 2, True, 30)); - Add(TFunction.CreateOper('+', _Add, 2, True, 40)); - Add(TFunction.CreateOper('-', _minus, 2, True, 40)); - Add(TBooleanFunction.CreateOper('>', _gt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('>=', _ge, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<=', _le, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<', _lt, 2, True, 50)); - Add(TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - Add(TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - Add(TBooleanFunction.CreateOper('in', _eq, 2, True, 10)); - Add(TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - Add(TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - Add(TBooleanFunction.CreateOper('and', _And, 2, True, 70)); - Add(TBooleanFunction.CreateOper('xor', _xor, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shl', _shl, 2, True, 70)); - Add(TBooleanFunction.CreateOper('shr', _shr, 2, True, 70)); - Add(TFunction.CreateOper(':=', _Assign, 2, True, 200)); - Add(TFunction.Create('exp', 'the value of e raised to the power of x', - _exp, 1)); - Add(TFunction.Create('if', 'if x=True(or 1) then y else z', _if, 3)); - Add(TVaryingFunction.Create('randg', - 'draw from normal distrib. (mean=x, sd =y)', _randG, 2)); - Add(TFunction.Create('sqr', 'the square of a number (x*x)', _sqr, 1)); - Add(TFunction.Create('sqrt', 'the square root of a number', _sqrt, 1)); - Add(TFunction.Create('abs', 'absolute value', _Abs, 1)); - Add(TFunction.Create('round', 'round to the nearest integer', _round, 1)); - Add(TFunction.Create('trunc', 'truncates a real number to an integer', - _trunc, 1)); - Add(TFunction.Create('ln', 'natural logarithm of x', _ln, 1)); - Add(TFunction.Create('log10', 'logarithm base 10 of x', _log10, 1)); - Add(TFunction.Create('logN', 'logarithm base x of y', _logN, 2)); - Add(TFunction.Create('power', 'power: x^y', _Power, 2)); - Add(TFunction.Create('pow', 'power: x^y', _Power, 2)); - Add(TFunction.Create('intpower', 'integer power: x^y', _IntPower, 2)); - Add(TFunction.Create('max', 'the maximum of both arguments', _max, 2)); - Add(TFunction.Create('min', 'the minimum of both arguments', _min, 2)); - Add(TFunction.Create('sin', 'sine of an angle in rad', _sin, 1)); - Add(TFunction.Create('cos', 'cosine of an angle in rad', _Cos, 1)); - Add(TFunction.Create('tan', 'tangent of an angle in rad', _tan, 1)); - Add(TFunction.Create('arcsin', 'inverse sine in rad', _ArcSin, 1)); - Add(TFunction.Create('arccos', 'inverse cosine in rad', _ArcCos, 1)); - Add(TFunction.Create('arctan2', 'inverse tangent (x/y) in rad', - _ArcTan2, 2)); - Add(TFunction.Create('arctan', 'inverse tangent (x/y) in rad', _arctan, 1)); - Add(TFunction.Create('sinh', 'hyperbolic sine of an angle in rad', - _Sinh, 1)); - Add(TFunction.Create('cosh', 'hyperbolic sine of an angle in rad', - _Cosh, 1)); - Add(TFunction.Create('tanh', 'hyperbolic tangent of an angle in rad', - _tanh, 1)); - Add(TFunction.Create('arcsinh', 'inverse sine in rad', _ArcSinh, 1)); - Add(TFunction.Create('arccosh', 'inverse hyperbolic cosine in rad', - _ArcCosh, 1)); - Add(TFunction.Create('arctanh', 'inverse hyperbolic tangent in rad', - _ArcTanh, 1)); - Add(TFunction.Create('degtorad', 'conversion of degrees to radians', - _DegToRad, 1)); - Add(TFunction.Create('radtodeg', 'conversion of rad to degrees', - _RadToDeg, 1)); - - DefineStringFunction('pos', 'Position in of substring in string', _Pos); - end; -end; - -function TExpressionParser.GetAsHexadecimal(AIndex: Integer): string; -var - D: Double; -begin - D := AsFloat[AIndex]; - result := Format(HexChar + '%x', [Round(D)]); -end; - -function TExpressionParser.GetExpression(AIndex: Integer): string; -begin - result := Expressions.Strings[AIndex]; -end; - -function TExpressionParser.GetExprSize(AIndex: Integer): Integer; -var - TheNext, ARec: PExpressionRec; -begin - result := 0; - if AIndex >= 0 then - begin - ARec := PExpressionRec(Expressions.Objects[AIndex]); - while ARec <> nil do - begin - TheNext := ARec.Next; - if (ARec.ExprWord <> nil) and not ARec.ExprWord.isVariable then - Inc(result); - ARec := TheNext; - end; - end; -end; - -procedure TExpressionParser.ReplaceExprWord(OldExprWord, - NewExprWord: TExprWord); -var - I: Integer; -begin - if OldExprWord.NFunctionArg <> NewExprWord.NFunctionArg then - raise Exception.Create(errorPrefix + - 'Cannot replace variable/function NFuntionArg doesn''t match'); - if Expressions <> nil then - for I := 0 to Expressions.Count - 1 do - begin - CurrentRec := PExpressionRec(Expressions.Objects[I]); - inherited; - end -end; - -function TExpressionParser.CurrentExpression: string; -begin - result := Expressions.Strings[CurrentIndex]; -end; - -{ TCStyleParser } - -procedure TCStyleParser.FillExpressList; -begin - inherited; - CStyle := True; -end; - -procedure TCStyleParser.SetCStyle(const Value: Boolean); -begin - FCStyle := Value; - if Value then - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TFunction.Create('fact', 'factorial', _factorial, 1)); - ReplaceFunction('div', TFunction.Create('div', 'integer division', - _Div, 2)); - ReplaceFunction('%', TFunction.Create('perc', 'percentage', - _Percentage, 1)); - ReplaceFunction('mod', TFunction.CreateOper('%', _mod, 2, True, 30)); - ReplaceFunction('or', TBooleanFunction.CreateOper('||', _or, 2, True, 70)); - ReplaceFunction('and', TBooleanFunction.CreateOper('&&', _And, 2, - True, 70)); - ReplaceFunction('shl', TBooleanFunction.CreateOper('<<', _shl, 2, - True, 70)); - ReplaceFunction('shr', TBooleanFunction.CreateOper('>>', _shr, 2, - True, 70)); - ReplaceFunction('=', TBooleanFunction.CreateOper('==', _eq, 2, True, 50)); - ReplaceFunction(':=', TFunction.CreateOper('=', _Assign, 2, True, 200)); - ReplaceFunction('<>', TBooleanFunction.CreateOper('!=', _ne, 2, True, 50)); - ReplaceFunction('not', TBooleanFunction.CreateOper('!', _not, 1, True, 60)); - end - else - begin - // note: mind the correct order of replacements - ReplaceFunction('!', TBooleanFunction.CreateOper('not', _not, 1, True, 60)); - ReplaceFunction('fact', TFunction.CreateOper('!', _factorial, 1, True, 10)); - ReplaceFunction('div', TFunction.CreateOper('div', _Div, 2, True, 30)); - ReplaceFunction('%', TFunction.CreateOper('mod', _mod, 2, True, 30)); - ReplaceFunction('perc', TFunction.CreateOper('%', _Percentage, 1, - True, 10)); - ReplaceFunction('||', TBooleanFunction.CreateOper('or', _or, 2, True, 70)); - ReplaceFunction('&&', TBooleanFunction.CreateOper('and', _And, 2, - True, 70)); - ReplaceFunction('<<', TBooleanFunction.CreateOper('shl', _shl, 2, - True, 70)); - ReplaceFunction('>>', TBooleanFunction.CreateOper('shr', _shr, 2, - True, 70)); - ReplaceFunction('=', TFunction.CreateOper(':=', _Assign, 2, True, 200)); - ReplaceFunction('==', TBooleanFunction.CreateOper('=', _eq, 2, True, 50)); - ReplaceFunction('!=', TBooleanFunction.CreateOper('<>', _ne, 2, True, 50)); - end; -end; - -end. diff --git a/contrib/ParseExpression/__history/oObjects.pas.~1~ b/contrib/ParseExpression/__history/oObjects.pas.~1~ deleted file mode 100644 index 0cb2b15..0000000 --- a/contrib/ParseExpression/__history/oObjects.pas.~1~ +++ /dev/null @@ -1,203 +0,0 @@ -unit OObjects; - -interface - -uses Classes; - -const - - { TOCollection interfaces between OWL TCollection and VCL TList } - MaxCollectionSize = Maxint div (SizeOf(Integer) * 2); - -type - TOCollection = class(TList) - public - constructor Create(ACapacity: Integer); - procedure AtFree(Index: Integer); - procedure FreeAll; - procedure DoFree(Item: Pointer); - procedure FreeItem(Item: Pointer); virtual; - destructor Destroy; override; - end; - - TNoOwnerCollection = class(TOCollection) - public - procedure FreeItem(Item: Pointer); override; - end; - - { TSortedCollection object } - - TSortedCollection = class(TOCollection) - public - Duplicates: Boolean; - constructor Create(ACapacity: Integer); - function Compare(Key1, Key2: Pointer): Integer; virtual; abstract; - function IndexOf(Item: Pointer): Integer; virtual; - procedure Add(Item: Pointer); virtual; - procedure AddReplace(Item: Pointer); virtual; - { if duplicate then replace the duplicate else add } - function KeyOf(Item: Pointer): Pointer; virtual; - function Search(Key: Pointer; var Index: Integer): Boolean; virtual; - end; - - { TStrCollection object } - - TStrCollection = class(TSortedCollection) - public - function Compare(Key1, Key2: Pointer): Integer; override; - procedure FreeItem(Item: Pointer); override; - end; - -implementation - -uses SysUtils; - -constructor TOCollection.Create(ACapacity: Integer); -begin - inherited Create; - SetCapacity(ACapacity); - { Delta is automatic in TList } -end; - -destructor TOCollection.Destroy; -begin - FreeAll; - inherited Destroy; -end; - -procedure TOCollection.AtFree(Index: Integer); -var - Item: Pointer; -begin - Item := Items[Index]; - Delete(Index); - FreeItem(Item); -end; - -procedure TOCollection.FreeAll; -var - I: Integer; -begin - try - for I := 0 to Count - 1 do - FreeItem(Items[I]); - finally - Count := 0; - end; -end; - -procedure TOCollection.DoFree(Item: Pointer); -begin - AtFree(IndexOf(Item)); -end; - -procedure TOCollection.FreeItem(Item: Pointer); -begin - if (Item <> nil) then - with TObject(Item) as TObject do - Free; -end; - -{ ----------------------------------------------------------------virtual; - Implementing TNoOwnerCollection - ----------------------------------------------------------------- } - -procedure TNoOwnerCollection.FreeItem(Item: Pointer); -begin -end; - -{ TSortedCollection } - -{$IFDEF maxComp} - -constructor TSortedCollection.Create(ACapacity, ADelta: Integer); -begin - inherited Create(ACapacity, ADelta); - Duplicates := False; -end; -{$ELSE} - -constructor TSortedCollection.Create(ACapacity: Integer); -begin - inherited Create(ACapacity); - Duplicates := False; -end; -{$ENDIF} - -function TSortedCollection.IndexOf(Item: Pointer): Integer; -var - I: Integer; -begin - IndexOf := -1; - if Search(KeyOf(Item), I) then - begin - if Duplicates then - while (I < Count) and (Item <> Items[I]) do - Inc(I); - if I < Count then - IndexOf := I; - end; -end; - -procedure TSortedCollection.AddReplace(Item: Pointer); -var - Index: Integer; -begin - if Search(KeyOf(Item), Index) then - Delete(Index); - Add(Item); -end; - -procedure TSortedCollection.Add(Item: Pointer); -var - I: Integer; -begin - if not Search(KeyOf(Item), I) or Duplicates then - Insert(I, Item); -end; - -function TSortedCollection.KeyOf(Item: Pointer): Pointer; -begin - KeyOf := Item; -end; - -function TSortedCollection.Search(Key: Pointer; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Search := False; - L := 0; - H := Count - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := Compare(KeyOf(Items[I]), Key); - if C < 0 then - L := I + 1 - else - begin - H := I - 1; - if C = 0 then - begin - Search := True; - if not Duplicates then - L := I; - end; - end; - end; - Index := L; -end; - -{ TStrCollection } - -function TStrCollection.Compare(Key1, Key2: Pointer): Integer; -begin - Compare := StrComp(PAnsiChar(Key1), PAnsiChar(Key2)); -end; - -procedure TStrCollection.FreeItem(Item: Pointer); -begin - StrDispose(PAnsiChar(Item)); -end; - -end. diff --git a/contrib/XXHASH4Delphi/.gitattributes b/contrib/XXHASH4Delphi/.gitattributes new file mode 100644 index 0000000..dfe0770 --- /dev/null +++ b/contrib/XXHASH4Delphi/.gitattributes @@ -0,0 +1,2 @@ +# Auto detect text files and perform LF normalization +* text=auto diff --git a/contrib/XXHASH4Delphi/.gitignore b/contrib/XXHASH4Delphi/.gitignore new file mode 100644 index 0000000..9532800 --- /dev/null +++ b/contrib/XXHASH4Delphi/.gitignore @@ -0,0 +1,69 @@ +# Uncomment these types if you want even more clean repository. But be careful. +# It can make harm to an existing project source. Read explanations below. +# +# Resource files are binaries containing manifest, project icon and version info. +# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. +#*.res +# +# Type library file (binary). In old Delphi versions it should be stored. +# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. +#*.tlb +# +# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. +# Uncomment this if you are not using diagrams or use newer Delphi version. +#*.ddp +# +# Visual LiveBindings file. Added in Delphi XE2. +# Uncomment this if you are not using LiveBindings Designer. +#*.vlb +# +# Deployment Manager configuration file for your project. Added in Delphi XE2. +# Uncomment this if it is not mobile development and you do not use remote debug feature. +#*.deployproj +# +# C++ object files produced when C/C++ Output file generation is configured. +# Uncomment this if you are not using external objects (zlib library for example). +#*.obj +# + +# Delphi compiler-generated binaries (safe to delete) +*.exe +*.dll +*.bpl +*.bpi +*.dcp +*.so +*.apk +*.drc +*.map +*.dres +*.rsm +*.tds +*.dcu +*.lib +*.a +*.o +*.ocx + +# Delphi autogenerated files (duplicated info) +*.cfg +*.hpp +*Resource.rc + +# Delphi local files (user-specific info) +*.local +*.identcache +*.projdata +*.tvsconfig +*.dsk + +# Delphi history and backups +__history/ +__recovery/ +*.~* + +# Castalia statistics file (since XE7 Castalia is distributed with Delphi) +*.stat + +# Boss dependency manager vendor folder https://github.com/HashLoad/boss +modules/ diff --git a/contrib/XXHASH4Delphi/README.md b/contrib/XXHASH4Delphi/README.md new file mode 100644 index 0000000..9344bf2 --- /dev/null +++ b/contrib/XXHASH4Delphi/README.md @@ -0,0 +1,21 @@ +# XXHASH4Delphi +XXHash Wrapper for Delphi +prebuild XXHash 0.8.1 Static Linked Object file with AVX2 or SSE2 support for both X64 and X86 platform. +Simple test program provided. + +xxHash is an Extremely fast Hash algorithm, running at RAM speed limits. It successfully completes the SMHasher test suite which evaluates collision, dispersion and randomness qualities of hash functions. Code is highly portable, and hashes are identical across all platforms (little / big endian). + +precompiled object files were compiled with GCC 11.2 with -O3 and -mAVX2 or -mSSE2 + +Check [XXHASH](https://github.com/Cyan4973/xxHash) for details. +For demos, check [YW_DEMOS](https://github.com/YWtheGod/YW_DEMOS) + +XXHash 0.8.1çš„é™æ€é“¾æŽ¥åº“，支æŒæ‰€æœ‰å¹³å°ï¼Œåœ¨éžWindowså¹³å°ä¸Šç›´æŽ¥é“¾æŽ¥ç³»ç»Ÿæ供的libxxhash.aé™æ€åº“文件，如需特殊指令集优化请自行é‡æ–°ç¼–译libxxhash.a文件。 + +Windowså¹³å°ä¸‹é»˜è®¤é‡‡ç”¨avx2指令集，如需兼容è€ç”µè„‘，å¯åˆ é™¤XXHASHLIB.pas文件中的第二行{$DEFINE AVX2}，å³å¯é€‰æ‹©é“¾æŽ¥SSE2指令集的目标文件。 +é™æ€é“¾æŽ¥çš„目标文件用GCC 11.2版本-O3优化编译并通过-må‚数指定指令集。 + +官方github: [XXHASH](https://github.com/Cyan4973/xxHash) +使用例å­ï¼š[YW_DEMOS](https://gitee.com/YWtheGod/YW_DEMOS) + +此算法惊人地快，适åˆä½œä¸ºMD5替代算法使用。 diff --git a/contrib/XXHASH4Delphi/XXHASH.pas b/contrib/XXHASH4Delphi/XXHASH.pas new file mode 100644 index 0000000..ac7cf8b --- /dev/null +++ b/contrib/XXHASH4Delphi/XXHASH.pas @@ -0,0 +1,1162 @@ +unit XXHASH; + +interface +uses Sysutils,Classes,xxhashlib +{$IFDEF YWRTL} //If you also installed my YWRTL package + //YWRTL package: https://github.com/YWtheGod/YWRTL + ,YWSTRUTIL //For a faster BinToHex + ,YWTypes //For a no lock buffer allocating +{$ENDIF} //use a system buildin implement instead will be just fine. + ; +type + //XXH3 128bits + {$ALIGN 16} + THashXXH3 = record + private + state : XXH3_state_t; + reserve : array[0..31] of byte; + function _state:PXXH3_state_t; inline; + procedure Update(const AData: PByte; ALength: NativeInt); overload; + public + class operator Assign (var Dest: THashXXH3; const [ref] Src: THashXXH3); + class function Create: THashXXH3; static; + class function SeedCreate(Seed:UInt64):THashXXH3; static; + procedure reset; + procedure SeedReset(Seed :UInt64); + procedure Update(const AData; const ALength: NativeInt); overload; + procedure Update(const AData: TBytes; const ALength: NativeInt = 0); + overload; + procedure Update(const Input: string); overload; + procedure Update(const Input: string; const Encoding : TEncoding); overload; + + procedure Update(const st: TStream; var size: NativeInt); overload; + function HashAsBytes : TBytes; overload; + function HashAsString: string; overload; + function HashAsUUID : TGuid; overload; + class function HashAsUUID(const B:Pointer; const L : NativeInt) : TGuid; + overload; static; + class function HashAsUUID(const Input : string):TGuid; overload; + static; + class function HashAsUUID(const Input : string; const Encoding : TEncoding): + TGuid; overload; static; + class function HashAsUUID(const AData: TBytes; const ALen: NativeInt = 0): + TGuid; overload; static; + class function HashAsUUID(const st : TStream; var size : NativeInt):TGuid; + overload; static; + class function HashAsUUID(const st : TStream):TGuid; + overload; static; + class function HashAsBytes(const B:Pointer; const L : NativeInt) : TBytes; + overload; static; + class function HashAsBytes(const AData: TBytes; const ALen: NativeInt = 0): + TBytes; overload; static; + class function HashAsBytes(const Input: string):TBytes; overload; + static; + class function HashAsBytes(const Input: string; const Encoding: TEncoding): + TBytes; overload; static; + class function HashAsBytes(const st : TStream; var size : NativeInt):TBytes; + overload; static; + class function HashAsBytes(const st : TStream):TBytes; + overload; static; + class function HashAsString(const B: Pointer; const L : NativeInt): string; + overload; static; + class function HashAsString(const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function HashAsString(const Input: string):string; overload; + static; + class function HashAsString(const Input: string; const Encoding: TEncoding): + string; overload; static; + class function HashAsString(const st: TStream; var size: NativeInt):string; + overload; static; + class function HashAsString(const st: TStream):string; + overload; static; + + class function SeedHashAsUUID(const Seed:UInt64; const B:Pointer; const L : NativeInt) : TGuid; + overload; static; + class function SeedHashAsUUID(const Seed:UInt64; const Input : string):TGuid; overload; + static; + class function SeedHashAsUUID(const Seed:UInt64; const Input : string; const Encoding : TEncoding): + TGuid; overload; static; + class function SeedHashAsUUID(const Seed:UInt64; const AData: TBytes; const ALen: NativeInt = 0): + TGuid; overload; static; + class function SeedHashAsUUID(const Seed:UInt64; const st : TStream; var size : NativeInt):TGuid; + overload; static; + class function SeedHashAsUUID(const Seed:UInt64; const st : TStream):TGuid; + overload; static; + class function SeedHashAsBytes(const Seed:UInt64; const B:Pointer; const L : NativeInt) : TBytes; + overload; static; + class function SeedHashAsBytes(const Seed:UInt64; const AData: TBytes; const ALen: NativeInt = 0): + TBytes; overload; static; + class function SeedHashAsBytes(const Seed:UInt64; const Input: string):TBytes; overload; + static; + class function SeedHashAsBytes(const Seed:UInt64; const Input: string; const Encoding: TEncoding): + TBytes; overload; static; + class function SeedHashAsBytes(const Seed:UInt64; const st : TStream; var size : NativeInt):TBytes; + overload; static; + class function SeedHashAsBytes(const Seed:UInt64; const st : TStream):TBytes; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const B: Pointer; const L : NativeInt): string; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function SeedHashAsString(const Seed:UInt64; const Input: string):string; overload; + static; + class function SeedHashAsString(const Seed:UInt64; const Input: string; const Encoding: TEncoding): + string; overload; static; + class function SeedHashAsString(const Seed:UInt64; const st: TStream; var size: NativeInt):string; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const st: TStream):string; + overload; static; + end; + + //XXH64 + THashXXH64 = record + private + state : XXH64_state_t; + reserve : array[0..31] of byte; + function _state:PXXH64_state_t; inline; + procedure Update(const AData: PByte; ALength: NativeInt); overload; + public + class operator Assign (var Dest: THashXXH64; const [ref] Src: THashXXH64); + class function Create: THashXXH64; static; + class function SeedCreate(Seed:UInt64):THashXXH64; static; + procedure reset; + procedure SeedReset(Seed :UInt64); + procedure Update(const AData; const ALength: NativeInt); overload; + procedure Update(const AData: TBytes; const ALength: NativeInt = 0); + overload; + procedure Update(const Input: string); overload; + procedure Update(const Input: string; const Encoding : TEncoding); overload; + + procedure Update(const st: TStream; var size: NativeInt); overload; + function HashAsString: string; overload; + function Hash : UInt64; overload; + class function Hash(const B:Pointer; const L : NativeInt) : UInt64; + overload; static; + class function Hash(const Input : string):UInt64; overload; + static; + class function Hash(const Input : string; const Encoding : TEncoding): + UInt64; overload; static; + class function Hash(const AData: TBytes; const ALen: NativeInt = 0): + UInt64; overload; static; + class function Hash(const st : TStream; var size : NativeInt):UInt64; + overload; static; + class function Hash(const st : TStream):UInt64; + overload; static; + class function HashAsString(const B: Pointer; const L : NativeInt): string; + overload; static; + class function HashAsString(const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function HashAsString(const Input: string):string; overload; + static; + class function HashAsString(const Input: string; const Encoding: TEncoding): + string; overload; static; + class function HashAsString(const st: TStream; var size: NativeInt):string; + overload; static; + class function HashAsString(const st: TStream):string; + overload; static; + class function SeedHash(const Seed:UInt64; const B:Pointer; const L : NativeInt) : UInt64; + overload; static; + class function SeedHash(const Seed:UInt64; const Input : string):UInt64; overload; + static; + class function SeedHash(const Seed:UInt64; const Input : string; const Encoding : TEncoding): + UInt64; overload; static; + class function SeedHash(const Seed:UInt64; const AData: TBytes; const ALen: NativeInt = 0): + UInt64; overload; static; + class function SeedHash(const Seed:UInt64; const st : TStream; var size : NativeInt):UInt64; + overload; static; + class function SeedHash(const Seed:UInt64; const st : TStream):UInt64; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const B: Pointer; const L : NativeInt): string; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function SeedHashAsString(const Seed:UInt64; const Input: string):string; overload; + static; + class function SeedHashAsString(const Seed:UInt64; const Input: string; const Encoding: TEncoding): + string; overload; static; + class function SeedHashAsString(const Seed:UInt64; const st: TStream; var size: NativeInt):string; + overload; static; + class function SeedHashAsString(const Seed:UInt64; const st: TStream):string; + overload; static; + end; + + //XXH32 + THashXXH32 = record + private + state : XXH32_state_t; + reserve : array[0..31] of byte; + function _state:PXXH32_state_t; inline; + procedure Update(const AData: PByte; ALength: NativeInt); overload; + public + class operator Assign (var Dest: THashXXH32; const [ref] Src: THashXXH32); + class function Create: THashXXH32; static; + class function SeedCreate(Seed:Cardinal):THashXXH32; static; + procedure reset; + procedure SeedReset(Seed :Cardinal); + procedure Update(const AData; const ALength: NativeInt); overload; + procedure Update(const AData: TBytes; const ALength: NativeInt = 0); + overload; + procedure Update(const Input: string); overload; + procedure Update(const Input: string; const Encoding : TEncoding); overload; + + procedure Update(const st: TStream; var size: NativeInt); overload; + function HashAsString: string; overload; + function Hash : Cardinal; overload; + class function Hash(const B:Pointer; const L : NativeInt) : Cardinal; + overload; static; + class function Hash(const Input : string):Cardinal; overload; + static; + class function Hash(const Input : string; const Encoding : TEncoding): + Cardinal; overload; static; + class function Hash(const AData: TBytes; const ALen: NativeInt = 0): + Cardinal; overload; static; + class function Hash(const st : TStream; var size : NativeInt):Cardinal; + overload; static; + class function Hash(const st : TStream):Cardinal; + overload; static; + class function HashAsString(const B: Pointer; const L : NativeInt): string; + overload; static; + class function HashAsString(const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function HashAsString(const Input: string):string; overload; + static; + class function HashAsString(const Input: string; const Encoding: TEncoding): + string; overload; static; + class function HashAsString(const st: TStream; var size: NativeInt):string; + overload; static; + class function HashAsString(const st: TStream):string; + overload; static; + class function SeedHash(const Seed:Cardinal; const B:Pointer; const L : NativeInt) : Cardinal; + overload; static; + class function SeedHash(const Seed:Cardinal; const Input : string):Cardinal; overload; + static; + class function SeedHash(const Seed:Cardinal; const Input : string; const Encoding : TEncoding): + Cardinal; overload; static; + class function SeedHash(const Seed:Cardinal; const AData: TBytes; const ALen: NativeInt = 0): + Cardinal; overload; static; + class function SeedHash(const Seed:Cardinal; const st : TStream; var size : NativeInt):Cardinal; + overload; static; + class function SeedHash(const Seed:Cardinal; const st : TStream):Cardinal; + overload; static; + class function SeedHashAsString(const Seed:Cardinal; const B: Pointer; const L : NativeInt): string; + overload; static; + class function SeedHashAsString(const Seed:Cardinal; const AData: TBytes; const ALen: NativeInt = 0): + string; overload; static; + class function SeedHashAsString(const Seed:Cardinal; const Input: string):string; overload; + static; + class function SeedHashAsString(const Seed:Cardinal; const Input: string; const Encoding: TEncoding): + string; overload; static; + class function SeedHashAsString(const Seed:Cardinal; const st: TStream; var size: NativeInt):string; + overload; static; + class function SeedHashAsString(const Seed:Cardinal; const st: TStream):string; + overload; static; + end; + +implementation +{$IFDEF MSWINDOWS} +uses libc; +{$ELSE} +uses Posix.String_; +{$ENDIF} +//uses Hash; + +function Hex128(const t : XXH128_hash_t):string; +begin + {$IFDEF YWRTL} + Result := BinToHex2(@t,sizeof(XXH128_hash_t)); + {$ELSE} + setlength(Result,sizeof(XXH128_hash_t)*2); + BinToHex(t,PWideChar(Result),sizeof(XXH128_hash_t)); + {$ENDIF} +end; + +function Hex64(const t : XXH64_hash_t):string; +begin + {$IFDEF YWRTL} + Result := BinToHex2(@t,sizeof(XXH64_hash_t)); + {$ELSE} + setlength(Result,sizeof(XXH64_hash_t)*2); + BinToHex(t,PWideChar(Result),sizeof(XXH64_hash_t)); + {$ENDIF} +end; + +function Hex32(const t : XXH32_hash_t):string; +begin + {$IFDEF YWRTL} + Result := BinToHex2(@t,sizeof(XXH32_hash_t)); + {$ELSE} + setlength(Result,sizeof(XXH32_hash_t)*2); + BinToHex(t,PWideChar(Result),sizeof(XXH32_hash_t)); + {$ENDIF} +end; + +procedure GetBuffer(var b : PByte); +begin + {$IFDEF YWRTL} + b := bufferpool128k.GetBuffer; + {$ELSE} + Getmem(b,128*1024); + {$ENDIF} +end; + +procedure FreeBuffer(var b : PByte); +begin + {$IFDEF YWLIB} + bufferpool128k.FreeBuffer(b); + {$ELSE} + FreeMem(b); + {$ENDIF} +end; + +function TrueLen(const AData: TBytes; const ALength:NativeInt):NativeInt; +begin + Result := Length(AData); + if (ALength>0)and(ALengthXXH_OK then + raise Exception.Create('XXH3_128bits_reset Error!'); +end; + +procedure THashXXH3.SeedReset(Seed: UInt64); +begin + if XXH3_128bits_reset_withSeed(_state^,Seed)<>XXH_OK then + raise Exception.Create('XXH3_128bits_reset Error!'); +end; + +procedure THashXXH3.Update(const Input: string; const Encoding: TEncoding); +begin + Update(Encoding.GetBytes(input)); +end; + +procedure THashXXH3.Update(const AData: PByte; ALength: NativeInt); +begin + if XXH3_128bits_update(_state^,AData,ALength)<>XXH_OK then + raise Exception.Create('XXH3_128bits_update ERROR!'); +end; + +procedure THashXXH3.Update(const AData; const ALength: NativeInt); +begin + Update(PByte(@AData), ALength); +end; + +procedure THashXXH3.Update(const st: TStream; var size: NativeInt); +var b : PByte; + s,u : integer; + t : NativeInt; +begin + t := 0; + GetBuffer(b); + try + u := 128*1024; + repeat + if (size>0)and(sizeXXH_OK then + raise Exception.Create('XXH64_reset Error!'); +end; + +procedure THashXXH64.SeedReset(Seed: UInt64); +begin + if XXH64_reset(_state^,Seed)<>XXH_OK then + raise Exception.Create('XXH64_reset Error!'); +end; + +procedure THashXXH64.Update(const Input: string; const Encoding: TEncoding); +begin + Update(Encoding.GetBytes(input)); +end; + +procedure THashXXH64.Update(const AData: PByte; ALength: NativeInt); +begin + if XXH64_update(_state^,AData,ALength)<>XXH_OK then + raise Exception.Create('XXH64_update ERROR!'); +end; + +procedure THashXXH64.Update(const AData; const ALength: NativeInt); +begin + Update(PByte(@AData), ALength); +end; + +procedure THashXXH64.Update(const st: TStream; var size: NativeInt); +var b : PByte; + s,u : integer; + t : NativeInt; +begin + t := 0; + GetBuffer(b); + try + u := 128*1024; + repeat + if (size>0)and(sizeXXH_OK then + raise Exception.Create('XXH32_reset Error!'); +end; + +procedure THashXXH32.SeedReset(Seed: Cardinal); +begin + if XXH32_reset(_state^,Seed)<>XXH_OK then + raise Exception.Create('XXH32_reset Error!'); +end; + +procedure THashXXH32.Update(const Input: string; const Encoding: TEncoding); +begin + Update(Encoding.GetBytes(input)); +end; + +procedure THashXXH32.Update(const AData: PByte; ALength: NativeInt); +begin + if XXH32_update(_state^,AData,ALength)<>XXH_OK then + raise Exception.Create('XXH32_update ERROR!'); +end; + +procedure THashXXH32.Update(const AData; const ALength: NativeInt); +begin + Update(PByte(@AData), ALength); +end; + +procedure THashXXH32.Update(const st: TStream; var size: NativeInt); +var b : PByte; + s,u : integer; + t : NativeInt; +begin + t := 0; + GetBuffer(b); + try + u := 128*1024; + repeat + if (size>0)and(size + + {CCB647AF-A713-4A4B-86C2-2827BECBD729} + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/contrib/XXHASH4Delphi/xxhash081.dpk b/contrib/XXHASH4Delphi/xxhash081.dpk new file mode 100644 index 0000000..77a9d06 --- /dev/null +++ b/contrib/XXHASH4Delphi/xxhash081.dpk @@ -0,0 +1,37 @@ +package xxhash081; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE RELEASE} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + XXHASHLIB in 'XXHASHLIB.pas', + XXHASH in 'XXHASH.pas'; + +end. diff --git a/contrib/XXHASH4Delphi/xxhash081.dproj b/contrib/XXHASH4Delphi/xxhash081.dproj new file mode 100644 index 0000000..15626ca --- /dev/null +++ b/contrib/XXHASH4Delphi/xxhash081.dproj @@ -0,0 +1,949 @@ + + + {D94915DD-FCB6-4F10-97CB-4867032A70EA} + xxhash081.dpk + 19.4 + None + True + Release + Win64 + 3 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + ..\$(ProductVersion)\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + All + xxhash081 + 2052 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + + + None + annotation-1.2.0.dex.jar;asynclayoutinflater-1.0.0.dex.jar;billing-4.0.0.dex.jar;browser-1.0.0.dex.jar;cloud-messaging.dex.jar;collection-1.0.0.dex.jar;coordinatorlayout-1.0.0.dex.jar;core-1.5.0-rc02.dex.jar;core-common-2.0.1.dex.jar;core-runtime-2.0.1.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;firebase-annotations-16.0.0.dex.jar;firebase-common-20.0.0.dex.jar;firebase-components-17.0.0.dex.jar;firebase-datatransport-18.0.0.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.0.0.dex.jar;firebase-installations-interop-17.0.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-22.0.0.dex.jar;fmx.dex.jar;fragment-1.0.0.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;legacy-support-core-ui-1.0.0.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.0.0.dex.jar;lifecycle-livedata-2.0.0.dex.jar;lifecycle-livedata-core-2.0.0.dex.jar;lifecycle-runtime-2.0.0.dex.jar;lifecycle-service-2.0.0.dex.jar;lifecycle-viewmodel-2.0.0.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;play-services-ads-20.1.0.dex.jar;play-services-ads-base-20.1.0.dex.jar;play-services-ads-identifier-17.0.0.dex.jar;play-services-ads-lite-20.1.0.dex.jar;play-services-base-17.5.0.dex.jar;play-services-basement-17.6.0.dex.jar;play-services-cloud-messaging-16.0.0.dex.jar;play-services-drive-17.0.0.dex.jar;play-services-games-21.0.0.dex.jar;play-services-location-18.0.0.dex.jar;play-services-maps-17.0.1.dex.jar;play-services-measurement-base-18.0.0.dex.jar;play-services-measurement-sdk-api-18.0.0.dex.jar;play-services-places-placereport-17.0.0.dex.jar;play-services-stats-17.0.0.dex.jar;play-services-tasks-17.2.0.dex.jar;print-1.0.0.dex.jar;room-common-2.1.0.dex.jar;room-runtime-2.1.0.dex.jar;slidingpanelayout-1.0.0.dex.jar;sqlite-2.0.1.dex.jar;sqlite-framework-2.0.1.dex.jar;swiperefreshlayout-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.0.0.dex.jar;transport-runtime-3.0.0.dex.jar;user-messaging-platform-1.0.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.1.0.dex.jar + + + None + annotation-1.2.0.dex.jar;asynclayoutinflater-1.0.0.dex.jar;billing-4.0.0.dex.jar;browser-1.0.0.dex.jar;cloud-messaging.dex.jar;collection-1.0.0.dex.jar;coordinatorlayout-1.0.0.dex.jar;core-1.5.0-rc02.dex.jar;core-common-2.0.1.dex.jar;core-runtime-2.0.1.dex.jar;cursoradapter-1.0.0.dex.jar;customview-1.0.0.dex.jar;documentfile-1.0.0.dex.jar;drawerlayout-1.0.0.dex.jar;firebase-annotations-16.0.0.dex.jar;firebase-common-20.0.0.dex.jar;firebase-components-17.0.0.dex.jar;firebase-datatransport-18.0.0.dex.jar;firebase-encoders-17.0.0.dex.jar;firebase-encoders-json-18.0.0.dex.jar;firebase-iid-interop-17.1.0.dex.jar;firebase-installations-17.0.0.dex.jar;firebase-installations-interop-17.0.0.dex.jar;firebase-measurement-connector-19.0.0.dex.jar;firebase-messaging-22.0.0.dex.jar;fmx.dex.jar;fragment-1.0.0.dex.jar;google-play-licensing.dex.jar;interpolator-1.0.0.dex.jar;javax.inject-1.dex.jar;legacy-support-core-ui-1.0.0.dex.jar;legacy-support-core-utils-1.0.0.dex.jar;lifecycle-common-2.0.0.dex.jar;lifecycle-livedata-2.0.0.dex.jar;lifecycle-livedata-core-2.0.0.dex.jar;lifecycle-runtime-2.0.0.dex.jar;lifecycle-service-2.0.0.dex.jar;lifecycle-viewmodel-2.0.0.dex.jar;listenablefuture-1.0.dex.jar;loader-1.0.0.dex.jar;localbroadcastmanager-1.0.0.dex.jar;play-services-ads-20.1.0.dex.jar;play-services-ads-base-20.1.0.dex.jar;play-services-ads-identifier-17.0.0.dex.jar;play-services-ads-lite-20.1.0.dex.jar;play-services-base-17.5.0.dex.jar;play-services-basement-17.6.0.dex.jar;play-services-cloud-messaging-16.0.0.dex.jar;play-services-drive-17.0.0.dex.jar;play-services-games-21.0.0.dex.jar;play-services-location-18.0.0.dex.jar;play-services-maps-17.0.1.dex.jar;play-services-measurement-base-18.0.0.dex.jar;play-services-measurement-sdk-api-18.0.0.dex.jar;play-services-places-placereport-17.0.0.dex.jar;play-services-stats-17.0.0.dex.jar;play-services-tasks-17.2.0.dex.jar;print-1.0.0.dex.jar;room-common-2.1.0.dex.jar;room-runtime-2.1.0.dex.jar;slidingpanelayout-1.0.0.dex.jar;sqlite-2.0.1.dex.jar;sqlite-framework-2.0.1.dex.jar;swiperefreshlayout-1.0.0.dex.jar;transport-api-3.0.0.dex.jar;transport-backend-cct-3.0.0.dex.jar;transport-runtime-3.0.0.dex.jar;user-messaging-platform-1.0.0.dex.jar;versionedparcelable-1.1.1.dex.jar;viewpager-1.0.0.dex.jar;work-runtime-2.1.0.dex.jar + + + None + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundleShortVersionString=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities;NSLocationUsageDescription=The reason for accessing the location information of the user;NSContactsUsageDescription=The reason for accessing the contacts;NSCalendarsUsageDescription=The reason for accessing the calendar data;NSRemindersUsageDescription=The reason for accessing the reminders;NSCameraUsageDescription=The reason for accessing the camera;NSMicrophoneUsageDescription=The reason for accessing the microphone;NSMotionUsageDescription=The reason for accessing the accelerometer;NSDesktopFolderUsageDescription=The reason for accessing the Desktop folder;NSDocumentsFolderUsageDescription=The reason for accessing the Documents folder;NSDownloadsFolderUsageDescription=The reason for accessing the Downloads folder;NSNetworkVolumesUsageDescription=The reason for accessing files on a network volume;NSRemovableVolumesUsageDescription=The reason for accessing files on a removable volume;NSSpeechRecognitionUsageDescription=The reason for requesting to send user data to Apple's speech recognition servers + Debug + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundleShortVersionString=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities;NSLocationUsageDescription=The reason for accessing the location information of the user;NSContactsUsageDescription=The reason for accessing the contacts;NSCalendarsUsageDescription=The reason for accessing the calendar data;NSRemindersUsageDescription=The reason for accessing the reminders;NSCameraUsageDescription=The reason for accessing the camera;NSMicrophoneUsageDescription=The reason for accessing the microphone;NSMotionUsageDescription=The reason for accessing the accelerometer;NSDesktopFolderUsageDescription=The reason for accessing the Desktop folder;NSDocumentsFolderUsageDescription=The reason for accessing the Documents folder;NSDownloadsFolderUsageDescription=The reason for accessing the Downloads folder;NSNetworkVolumesUsageDescription=The reason for accessing files on a network volume;NSRemovableVolumesUsageDescription=The reason for accessing files on a removable volume;NSSpeechRecognitionUsageDescription=The reason for requesting to send user data to Apple's speech recognition servers + Debug + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + true + true + off + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + auto + + + true + 1033 + + + true + 1033 + + + + MainSource + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Package + + + + xxhash081.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + + + true + + + + + true + + + + + true + + + + + xxhash081.bpl + true + + + + + xxhash081.bpl + true + + + + + 1 + + + 0 + + + + + classes + 64 + + + classes + 64 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + + + + False + False + False + False + False + False + True + True + + + 12 + + + + + diff --git a/contrib/XXHASH4Delphi/xxhash081.res b/contrib/XXHASH4Delphi/xxhash081.res new file mode 100644 index 0000000..13c3dcb Binary files /dev/null and b/contrib/XXHASH4Delphi/xxhash081.res differ diff --git a/contrib/XXHASH4Delphi/xxhash4delphi.SSE2.c b/contrib/XXHASH4Delphi/xxhash4delphi.SSE2.c new file mode 100644 index 0000000..d512549 --- /dev/null +++ b/contrib/XXHASH4Delphi/xxhash4delphi.SSE2.c @@ -0,0 +1,46 @@ +/* + * xxHash - Extremely Fast Hash algorithm + * Copyright (C) 2012-2020 Yann Collet + * + * BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following disclaimer + * in the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * You can contact the author at: + * - xxHash homepage: https://www.xxhash.com + * - xxHash source repository: https://github.com/Cyan4973/xxHash + */ + + +/* + * xxhash.c instantiates functions defined in xxhash.h + */ + +#define XXH_STATIC_LINKING_ONLY /* access advanced declarations */ +#define XXH_IMPLEMENTATION /* access definitions */ +#define XXH_FORCE_MEMORY_ACCESS 1 +#define XXH_VECTOR XXH_SSE2 +#define XXH_DEBUGLEVEL 0 + +#include "xxhash.h" diff --git a/contrib/XXHASH4Delphi/xxhash4delphi.avx2.c b/contrib/XXHASH4Delphi/xxhash4delphi.avx2.c new file mode 100644 index 0000000..1b28044 --- /dev/null +++ b/contrib/XXHASH4Delphi/xxhash4delphi.avx2.c @@ -0,0 +1,46 @@ +/* + * xxHash - Extremely Fast Hash algorithm + * Copyright (C) 2012-2020 Yann Collet + * + * BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * * Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * * Redistributions in binary form must reproduce the above + * copyright notice, this list of conditions and the following disclaimer + * in the documentation and/or other materials provided with the + * distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * You can contact the author at: + * - xxHash homepage: https://www.xxhash.com + * - xxHash source repository: https://github.com/Cyan4973/xxHash + */ + + +/* + * xxhash.c instantiates functions defined in xxhash.h + */ + +#define XXH_STATIC_LINKING_ONLY /* access advanced declarations */ +#define XXH_IMPLEMENTATION /* access definitions */ +#define XXH_FORCE_MEMORY_ACCESS 1 +#define XXH_VECTOR XXH_AVX2 +#define XXH_DEBUGLEVEL 0 + +#include "xxhash.h" diff --git a/dbgenerator/DbgMain.pas b/dbgenerator/DbgMain.pas index 3ccc2c8..0162ab7 100644 --- a/dbgenerator/DbgMain.pas +++ b/dbgenerator/DbgMain.pas @@ -143,7 +143,7 @@ begin while Y > 0 do begin Inc(HashList[I].Size, Y); - HashList[I].Hash := Utils.Hash32(HashList[I].Hash, @Buffer[0], Y); + HashList[I].Hash := Utils.CRC32(HashList[I].Hash, @Buffer[0], Y); Dec(X, Y); Y := Stream.Read(Buffer[0], Min(X, BufferSize)); end; @@ -179,7 +179,6 @@ var OStream, MStream: TMemoryStream; DataStore: TDataStore1; Tasks: TArray; - NStream: TArray; InfoStore: TArray>; begin SetLength(SearchInfo, $10000); @@ -199,12 +198,8 @@ begin BaseDir := ExtractFilePath(TPath.GetFullPath(Input1)); LList := GetFileList([Input1], True); SetLength(Tasks, Options.Threads); - SetLength(Tasks, Options.Threads); for I := Low(Tasks) to High(Tasks) do - begin Tasks[I] := TTask.Create(I); - NStream[I] := TMemoryStream.Create; - end; for I := Low(LList) to High(LList) do begin if InRange(FileSize(LList[I]), MinSize1, Integer.MaxValue) then @@ -219,14 +214,14 @@ begin J := MinSize1; LSInfo.CRCSize := J; LSInfo.ActualSize := FileSize(LList[I]); - LSInfo.CRC1 := Utils.Hash32(0, @Buffer[0], J); + LSInfo.CRC1 := Utils.CRC32(0, @Buffer[0], J); LSInfo.CRC2 := LSInfo.CRC1; while (J > 0) and (LSInfo.CRCSize < Options.ChunkSize) do begin J := Read(Buffer[0], Min(Options.ChunkSize - LSInfo.CRCSize, BufferSize)); Inc(LSInfo.CRCSize, J); - LSInfo.CRC2 := Utils.Hash32(LSInfo.CRC2, @Buffer[0], J); + LSInfo.CRC2 := Utils.CRC32(LSInfo.CRC2, @Buffer[0], J); end; Insert(LSInfo, SearchInfo[A, B], Length(SearchInfo[A, B])); Inc(SearchCount[A, B]); @@ -241,8 +236,6 @@ begin WriteLn(ErrOutput, Format('Skipped %s (Larger than %d)', [ReplaceText(LList[I], BaseDir, ''), Integer.MaxValue])); end; - for I := Low(Tasks) to High(Tasks) do - NStream[I].Free; DataStore := TDataStore1.Create(nil, True, Options.Threads, Options.ChunkSize); SetLength(InfoStore, Options.Threads); @@ -284,12 +277,12 @@ begin if (SearchCount[C, D] > 0) then begin F := False; - CRC := Utils.Hash32(0, Ptr + Pos, MinSize1); + CRC := Utils.CRC32(0, Ptr + Pos, MinSize1); for Y := 0 to SearchCount[C, D] - 1 do begin if (SearchInfo[C, D, Y].CRCSize <= (SizeEx - Pos)) then if (CRC = SearchInfo[C, D, Y].CRC1) and - (Utils.Hash32(CRC, Ptr + Pos + MinSize1, SearchInfo[C, D, + (Utils.CRC32(CRC, Ptr + Pos + MinSize1, SearchInfo[C, D, Y].CRCSize - MinSize1) = SearchInfo[C, D, Y].CRC2) then begin E.Position := DataStore.Position(X) + Pos; @@ -328,7 +321,7 @@ begin Found2 := False; DataStore.ChangeInput(FStream); DataStore.Load; - Hash := Utils.Hash32(0, DataStore.Slot(0).Memory, MinSize2); + Hash := Utils.CRC32(0, DataStore.Slot(0).Memory, MinSize2); MStream.WriteBuffer(DataStore.Slot(0).Memory^, Integer.Size); MStream.WriteBuffer(PInteger(PByte(DataStore.Slot(0).Memory) + MinSize2 - Integer.Size)^, Integer.Size); @@ -397,14 +390,11 @@ begin begin InfoStore[I].Free; Tasks[I].Free; - NStream[I].Free; end; DataStore.Free; OStream.Free; MStream.Free; end; - for I := Low(InfoStore) to High(InfoStore) do - Tasks[I].Free; end; end. diff --git a/imports/FLZMA2DLL.pas b/imports/FLZMA2DLL.pas index 1161e81..bf5ff44 100644 --- a/imports/FLZMA2DLL.pas +++ b/imports/FLZMA2DLL.pas @@ -6,7 +6,17 @@ uses InitCode, Utils, LibImport, WinAPI.Windows, - System.SysUtils, System.Classes, System.Types; + System.SysUtils, System.Math, System.Classes, System.Types; + +const + FL2_DICTLOG_MIN = 20; +{$IFDEF CPU32BITS} + FL2_DICTLOG_MAX = 27; +{$ELSE} + FL2_DICTLOG_MAX = 30; +{$ENDIF} + FL2_DICTSIZE_MIN = (1 shl FL2_DICTLOG_MIN); + FL2_DICTSIZE_MAX = (1 shl FL2_DICTLOG_MAX); type PFL2_inBuffer = ^FL2_inBuffer; @@ -150,31 +160,28 @@ var DLLLoaded: boolean = False; type - TLZMACRec = record - Threads: Integer; - Level: Integer; - HighCompress: boolean; - procedure Parse(S: String); - end; - - TLZMADRec = record - Threads: Integer; - procedure Parse(S: String); - end; - TLZMACompressStream = class(TStream) private const FBufferSize = 65536; private FCtx: Pointer; - FProp: TLZMACRec; + FThreads, FLevel, FDictionary: Integer; + FHighCompress: boolean; FOutput: TStream; FBuffer: array [0 .. FBufferSize - 1] of Byte; + FInSize, FOutSize: Int64; FInitialized: boolean; public - constructor Create(AOutput: TStream; AConfig: String); + constructor Create(AOutput: TStream); destructor Destroy; override; function Write(const Buffer; Count: LongInt): LongInt; override; + procedure Flush; + property Threads: Integer read FThreads write FThreads; + property Level: Integer read FLevel write FLevel; + property Dictionary: Integer read FDictionary write FDictionary; + property HighCompress: boolean read FHighCompress write FHighCompress; + property InSize: Int64 read FInSize; + property OutSize: Int64 read FOutSize; end; TLZMADecompressStream = class(TStream) @@ -182,14 +189,16 @@ type FBufferSize = 65536; private FCtx: Pointer; - FProp: TLZMADRec; FInp: FL2_inBuffer; FInput: TStream; FBuffer: array [0 .. FBufferSize - 1] of Byte; + FInSize, FOutSize: Int64; public - constructor Create(AInput: TStream; AConfig: String = ''); + constructor Create(AInput: TStream); destructor Destroy; override; function Read(var Buffer; Count: Integer): Integer; override; + property InSize: Int64 read FInSize; + property OutSize: Int64 read FOutSize; end; implementation @@ -197,76 +206,24 @@ implementation var Lib: TLibImport; -procedure TLZMACRec.Parse(S: string); -var - List: TStringDynArray; - I, J: Integer; -begin - Threads := 1; - Level := 6; - HighCompress := False; - List := DecodeStr(S, ':'); - for I := Low(List) to High(List) do - begin - if List[I].StartsWith('t', True) then - Threads := ConvertToThreads(List[I].Substring(1)); - if List[I].StartsWith('l', True) then - Level := List[I].Substring(1).ToInteger; - if List[I].StartsWith('hi', True) then - HighCompress := List[I].Substring(2).ToBoolean; - end; -end; - -procedure TLZMADRec.Parse(S: string); -var - List: TStringDynArray; - I: Integer; -begin - Threads := 1; - List := DecodeStr(S, ':'); - for I := Low(List) to High(List) do - begin - if List[I].StartsWith('t', True) then - Threads := ConvertToThreads(List[I].Substring(1)); - end; -end; - -constructor TLZMACompressStream.Create(AOutput: TStream; AConfig: String); -var - LConfig: String; +constructor TLZMACompressStream.Create(AOutput: TStream); begin inherited Create; - LConfig := AConfig; - if LConfig = '' then - LConfig := 't50p'; - FProp.Parse(LConfig); + FThreads := ConvertToThreads('50p'); + FLevel := 6; + FDictionary := 0; + FHighCompress := False; FOutput := AOutput; - if FProp.Threads > 1 then - FCtx := FL2_createCStreamMt(FProp.Threads, 0) - else - FCtx := FL2_createCStream; - FL2_CStream_setParameter(FCtx, FL2_cParameter.FL2_p_highCompression, - Integer(FProp.HighCompress)); + FInSize := 0; + FOutSize := 0; FInitialized := False; end; destructor TLZMACompressStream.Destroy; -var - Oup: FL2_outBuffer; - Res: size_t; begin + Flush; if FInitialized then - begin - Oup.dst := @FBuffer[0]; - Oup.size := FBufferSize; - Oup.pos := 0; - repeat - Res := FL2_endStream(FCtx, @Oup); - FOutput.WriteBuffer(FBuffer[0], Oup.pos); - Oup.pos := 0; - until Res = 0; - end; - FL2_freeCCtx(FCtx); + FL2_freeCCtx(FCtx); inherited Destroy; end; @@ -278,7 +235,18 @@ begin Result := 0; if not FInitialized then begin - FL2_initCStream(FCtx, FProp.Level); + if FThreads > 1 then + FCtx := FL2_createCStreamMt(FThreads, 0) + else + FCtx := FL2_createCStream; + FL2_CStream_setParameter(FCtx, FL2_cParameter.FL2_p_highCompression, + Integer(FHighCompress)); + FL2_CStream_setParameter(FCtx, + FL2_cParameter.FL2_p_compressionLevel, FLevel); + if FDictionary > 0 then + FL2_CStream_setParameter(FCtx, FL2_cParameter.FL2_p_dictionarySize, + FDictionary); + FL2_initCStream(FCtx, 0); FInitialized := True; end; Inp.src := PByte(@Buffer); @@ -292,34 +260,44 @@ begin if not boolean(FL2_isError(FL2_compressStream(FCtx, @Oup, @Inp))) then begin FOutput.WriteBuffer(FBuffer[0], Oup.pos); + Inc(FOutSize, Oup.pos); Oup.pos := 0; end; end; Result := Inp.pos; + Inc(FInSize, Result); end; -constructor TLZMADecompressStream.Create(AInput: TStream; AConfig: String); +procedure TLZMACompressStream.Flush; var - LConfig: String; - LSize: Int64; + Oup: FL2_outBuffer; + Res: size_t; +begin + if FInitialized then + begin + Oup.dst := @FBuffer[0]; + Oup.size := FBufferSize; + Oup.pos := 0; + repeat + Res := FL2_endStream(FCtx, @Oup); + FOutput.WriteBuffer(FBuffer[0], Oup.pos); + Inc(FOutSize, Oup.pos); + Oup.pos := 0; + until Res = 0; + end; +end; + +constructor TLZMADecompressStream.Create(AInput: TStream); begin inherited Create; - LConfig := AConfig; - if LConfig = '' then - LConfig := 't25p'; - FProp.Parse(LConfig); FInput := AInput; - LSize := 0; - LSize := LSize.MaxValue; - if FProp.Threads > 1 then - begin - FCtx := FL2_createDStreamMt(FProp.Threads); - FL2_setDStreamMemoryLimitMt(FCtx, LSize); - end - else - FCtx := FL2_createDStream; + { FCtx := FL2_createDStream; + FL2_setDStreamMemoryLimitMt(FCtx, 0); } + FCtx := FL2_createDStream; FL2_initDStream(FCtx); FillChar(FInp, SizeOf(FL2_inBuffer), 0); + FInSize := 0; + FOutSize := 0; end; destructor TLZMADecompressStream.Destroy; diff --git a/imports/LZ4DLL.pas b/imports/LZ4DLL.pas index 3ed7ae7..a374a2c 100644 --- a/imports/LZ4DLL.pas +++ b/imports/LZ4DLL.pas @@ -244,8 +244,7 @@ begin end; const - DLLParam1 = '--lz4='; - DLLParam2 = '-l4'; + DLLParam = '-lz4'; var I: Integer; @@ -256,14 +255,9 @@ initialization DLLFile := PluginsPath + 'liblz4.dll'; for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(DLLParam1) then + if ParamStr(I).StartsWith(DLLParam) then begin - DLLFile := ParamStr(I).Substring(DLLParam1.Length); - break; - end; - if ParamStr(I).StartsWith(DLLParam2) then - begin - DLLFile := ParamStr(I).Substring(DLLParam2.Length); + DLLFile := ParamStr(I).Substring(DLLParam.Length); break; end; end; diff --git a/imports/LZODLL.pas b/imports/LZODLL.pas index b015c75..1f4f2af 100644 --- a/imports/LZODLL.pas +++ b/imports/LZODLL.pas @@ -95,8 +95,7 @@ begin end; const - DLLParam1 = '-lzo='; - DLLParam2 = '-lo'; + DLLParam = '-lzo'; var I: integer; @@ -107,14 +106,9 @@ initialization DLLFile := PluginsPath + 'lzo2.dll'; for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(DLLParam1) then + if ParamStr(I).StartsWith(DLLParam) then begin - DLLFile := ParamStr(I).Substring(DLLParam1.Length); - break; - end; - if ParamStr(I).StartsWith(DLLParam2) then - begin - DLLFile := ParamStr(I).Substring(DLLParam2.Length); + DLLFile := ParamStr(I).Substring(DLLParam.Length); break; end; end; diff --git a/imports/OodleDLL.pas b/imports/OodleDLL.pas index f037ea8..655ef73 100644 --- a/imports/OodleDLL.pas +++ b/imports/OodleDLL.pas @@ -8,6 +8,9 @@ uses WinAPI.Windows, System.SysUtils, System.Types, System.IOUtils; +const + OODLELZ_SCRATCH_MEM_NO_BOUND = NativeUInt(-1); + type POodleLZ_CompressOptions = ^TOodleLZ_CompressOptions; @@ -32,6 +35,8 @@ type end; var + OldCompress, OldCompressOptions_GetDefault, + OldGetCompressedBufferSizeNeeded: Boolean; Oodle_CheckVersion: function(oodle_header_version: Cardinal; pOodleLibVersion: PCardinal = nil): LongBool stdcall; OodleLZ_Compress_1: function(compressor: Integer; rawBuf: Pointer; @@ -58,6 +63,9 @@ var : NativeUInt stdcall; OodleLZ_GetCompressedBufferSizeNeeded_2: function(compressor: Integer; rawSize: NativeUInt): NativeUInt stdcall; + OodleLZ_GetCompressScratchMemBound: function(compressor: Integer; + compressSelect: Integer; rawSize: NativeUInt; + pOptions: POodleLZ_CompressOptions): NativeUInt stdcall = nil; DLLLoaded: Boolean = False; @@ -75,8 +83,6 @@ implementation var Lib: TLibImport; - OldCompress, OldCompressOptions_GetDefault, - OldGetCompressedBufferSizeNeeded: Boolean; procedure Init(Filename: String); var @@ -163,6 +169,20 @@ begin end; @OodleLZ_GetCompressedBufferSizeNeeded_2 := @OodleLZ_GetCompressedBufferSizeNeeded_1; + if not OldCompress then + begin + OodleLZ_GetCompressScratchMemBound := + Lib.GetProcAddr('OodleLZ_GetCompressScratchMemBound'); + if not Assigned(OodleLZ_GetCompressScratchMemBound) then + for I := 0 to 32 do + begin + @OodleLZ_GetCompressScratchMemBound := + Lib.GetProcAddr(PAnsiChar('_OodleLZ_GetCompressScratchMemBound@' + + (I * 2).ToString)); + if Assigned(OodleLZ_GetCompressScratchMemBound) then + break; + end; + end; end; end; @@ -203,8 +223,7 @@ begin end; const - DLLParam1 = '--oodle='; - DLLParam2 = '-od'; + DLLParam = '-oodle'; var I: Integer; @@ -215,14 +234,9 @@ initialization DLLFile := PluginsPath + 'oo2core_9_win64.dll'; for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(DLLParam1) then + if ParamStr(I).StartsWith(DLLParam) then begin - DLLFile := ParamStr(I).Substring(DLLParam1.Length); - break; - end; - if ParamStr(I).StartsWith(DLLParam2) then - begin - DLLFile := ParamStr(I).Substring(DLLParam2.Length); + DLLFile := ParamStr(I).Substring(DLLParam.Length); break; end; end; diff --git a/imports/ZLibDLL.pas b/imports/ZLibDLL.pas index bb96d44..1611be5 100644 --- a/imports/ZLibDLL.pas +++ b/imports/ZLibDLL.pas @@ -188,8 +188,7 @@ begin end; const - DLLParam1 = '--zlib='; - DLLParam2 = '-zb'; + DLLParam = '-zlib'; var I: integer; @@ -200,14 +199,9 @@ initialization DLLFile := PluginsPath + 'zlibwapi.dll'; for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(DLLParam1) then + if ParamStr(I).StartsWith(DLLParam) then begin - DLLFile := ParamStr(I).Substring(DLLParam1.Length); - break; - end; - if ParamStr(I).StartsWith(DLLParam2) then - begin - DLLFile := ParamStr(I).Substring(DLLParam2.Length); + DLLFile := ParamStr(I).Substring(DLLParam.Length); break; end; end; diff --git a/imports/ZSTDDLL.pas b/imports/ZSTDDLL.pas index a0d865e..032acf0 100644 --- a/imports/ZSTDDLL.pas +++ b/imports/ZSTDDLL.pas @@ -186,8 +186,7 @@ begin end; const - DLLParam1 = '--zstd='; - DLLParam2 = '-zs'; + DLLParam = '-zstd'; var I: Integer; @@ -198,14 +197,9 @@ initialization DLLFile := PluginsPath + 'libzstd.dll'; for I := 1 to ParamCount do begin - if ParamStr(I).StartsWith(DLLParam1) then + if ParamStr(I).StartsWith(DLLParam) then begin - DLLFile := ParamStr(I).Substring(DLLParam1.Length); - break; - end; - if ParamStr(I).StartsWith(DLLParam2) then - begin - DLLFile := ParamStr(I).Substring(DLLParam2.Length); + DLLFile := ParamStr(I).Substring(DLLParam.Length); break; end; end; diff --git a/io/IOPatch.pas b/io/IOPatch.pas index eec00c0..242ff7d 100644 --- a/io/IOPatch.pas +++ b/io/IOPatch.pas @@ -211,7 +211,6 @@ begin Options.MaxSize) then continue; end; - ShowMessage(LFilename); LEntry.Op := TPatchOp.opMissing; LEntry.Filename := LList2[I]; LEntry.Size := FileSize(BaseDir2 + LList2[I]); diff --git a/precompressor/PrecompEXE.pas b/precompressor/PrecompEXE.pas index c6cd451..e7389ac 100644 --- a/precompressor/PrecompEXE.pas +++ b/precompressor/PrecompEXE.pas @@ -122,7 +122,7 @@ begin end; function ExecStdioProcess(Ctx: PExecCtx; InBuff: Pointer; - var InSize, OutSize: Integer; Output: _ExecOutput): Boolean; + InSize, OutSize: Integer; Output: _ExecOutput): Boolean; function ProcessLib(Instance: Integer; Stdin, Stdout: THandle): Boolean; const @@ -131,18 +131,20 @@ function ExecStdioProcess(Ctx: PExecCtx; InBuff: Pointer; Buffer: array [0 .. BufferSize - 1] of Byte; BytesRead: DWORD; X: Integer; + LOutSize: Integer; begin Result := False; + LOutSize := OutSize; try FileWriteBuffer(Stdin, InSize, InSize.Size); - FileWriteBuffer(Stdin, OutSize, OutSize.Size); + FileWriteBuffer(Stdin, LOutSize, LOutSize.Size); FileWriteBuffer(Stdin, InBuff^, InSize); - FileReadBuffer(Stdout, OutSize, OutSize.Size); - if OutSize <= 0 then + FileReadBuffer(Stdout, LOutSize, LOutSize.Size); + if LOutSize <= 0 then exit else begin - X := OutSize; + X := LOutSize; while X > 0 do begin BytesRead := Min(X, Length(Buffer)); @@ -636,16 +638,16 @@ begin SI.Option := StreamInfo.Option; if ExeDecode(X, Instance, Input, @SI, Funcs) then begin - Funcs^.LogRestore(PChar(Codec.Names[X]), nil, StreamInfo.OldSize, - StreamInfo.NewSize, Res1, True); Buffer := Funcs^.Allocator(Instance, CodecSize[Instance]); Res1 := CodecSize[Instance]; - Funcs^.LogPatch2(StreamInfo.OldSize, Res1, StreamInfo.ExtSize, Res2 > 0); + Funcs^.LogRestore(PChar(Codec.Names[X]), nil, StreamInfo.OldSize, + StreamInfo.NewSize, Res1, True); if GetBits(StreamInfo.Option, 31, 1) = 1 then begin Buffer := Funcs^.Allocator(Instance, Res1 + StreamInfo.OldSize); Res2 := PrecompDecodePatch(InputExt, StreamInfo.ExtSize, Buffer, Res1, Buffer + Res1, StreamInfo.OldSize); + Funcs^.LogPatch2(StreamInfo.OldSize, Res1, StreamInfo.ExtSize, Res2 > 0); if Res2 > 0 then begin Output(Instance, Buffer + Res1, StreamInfo.OldSize); diff --git a/precompressor/PrecompINIEx.pas b/precompressor/PrecompINIEx.pas index 0ad35f1..c666de7 100644 --- a/precompressor/PrecompINIEx.pas +++ b/precompressor/PrecompINIEx.pas @@ -47,7 +47,7 @@ type StreamPosition, StreamOffset, OldSize, NewSize, DepthSize: String; Names, Exprs: TArray; Values: TArray; - Conditions: TArray; + Conditions: array [0 .. 2] of TArray; end; PCfgRecDynArray = ^TCfgRecDynArray; @@ -149,9 +149,12 @@ begin Exprs[Y] := CodecCfg[0, J, X].Exprs[Y]; Values[Y] := CodecCfg[0, J, X].Values[Y]; end; - SetLength(Conditions, Length(CodecCfg[0, J, X].Conditions)); - for Y := Low(Conditions) to High(Conditions) do - Conditions[Y] := CodecCfg[0, J, X].Conditions[Y]; + for Z := Low(Conditions) to High(Conditions) do + begin + SetLength(Conditions[Z], Length(CodecCfg[0, J, X].Conditions[Z])); + for Y := Low(Conditions[Z]) to High(Conditions[Z]) do + Conditions[Z, Y] := CodecCfg[0, J, X].Conditions[Z, Y]; + end; for Z := Low(Structure) to High(Structure) do for Y := Low(Structure[Z]) to High(Structure[Z]) do Parser.DefineVariable(Structure[Z, Y].Name, @@ -331,6 +334,12 @@ begin if Status = TScanStatus.Fail then break; end; + for Y := Low(Conditions[0]) to High(Conditions[0]) do + if Round(Parser.Evaluate(Conditions[0, Y])) = 0 then + begin + Status := TScanStatus.Fail; + break; + end; if Status = TScanStatus.Fail then begin Inc(Pos); @@ -369,68 +378,75 @@ begin end; if Status = TScanStatus.Fail then break; - StreamPosInt1 := Pos + Round(Parser.Evaluate(StreamPosition)); - StreamPosInt2 := StreamPosInt1; - for Y := Low(Structure[2]) to High(Structure[2]) do - begin - if (Structure[2, Y].BeforeStream = True) then + for Y := Low(Conditions[1]) to High(Conditions[1]) do + if Round(Parser.Evaluate(Conditions[1, Y])) = 0 then begin - if Structure[2, Y].Name = 'Stream' then - begin - StreamPosInt1 := StreamPosInt2; - continue; - end; - Funcs^.ReadFuture(Instance, StreamPosInt2, - Structure[2, Y].Data, Structure[2, Y].Size); - I64 := 0; - EndianMove(Structure[2, Y].Data, @I64, - Min(Structure[2, Y].Size, I64.Size), BigEndian); - Structure[2, Y].Value := I64.ToDouble; - Inc(StreamPosInt2, Structure[2, Y].Size); + Status := TScanStatus.Fail; + break; end; - end; - for A := Low(Exprs) to High(Exprs) do + if Status = TScanStatus.None then begin - for B := Low(Exprs) to High(Exprs) do - try - if A = B then + StreamPosInt1 := Pos + + Round(Parser.Evaluate(StreamPosition)); + StreamPosInt2 := StreamPosInt1; + for Y := Low(Structure[2]) to High(Structure[2]) do + begin + if (Structure[2, Y].BeforeStream = True) then + begin + if Structure[2, Y].Name = 'Stream' then + begin + StreamPosInt1 := StreamPosInt2; continue; - Values[B] := Parser.Evaluate(Exprs[B]); + end; + Funcs^.ReadFuture(Instance, StreamPosInt2, + Structure[2, Y].Data, Structure[2, Y].Size); + I64 := 0; + EndianMove(Structure[2, Y].Data, @I64, + Min(Structure[2, Y].Size, I64.Size), BigEndian); + Structure[2, Y].Value := I64.ToDouble; + Inc(StreamPosInt2, Structure[2, Y].Size); + end; + end; + for A := Low(Exprs) to High(Exprs) do + begin + for B := Low(Exprs) to High(Exprs) do + try + if A = B then + continue; + Values[B] := Parser.Evaluate(Exprs[B]); + except + end; + try + Values[A] := Parser.Evaluate(Exprs[A]); except end; - try - Values[A] := Parser.Evaluate(Exprs[A]); - except end; - end; - StreamOffsetInt := Round(Parser.Evaluate(StreamOffset)); - OldSizeInt := Round(Parser.Evaluate(OldSize)); - NewSizeInt := Round(Parser.Evaluate(NewSize)); - DepthSizeInt := Round(Parser.Evaluate(DepthSize)); - for Y := Low(Structure[2]) to High(Structure[2]) do - begin - if (Structure[2, Y].BeforeStream = False) then + StreamOffsetInt := Round(Parser.Evaluate(StreamOffset)); + OldSizeInt := Round(Parser.Evaluate(OldSize)); + NewSizeInt := Round(Parser.Evaluate(NewSize)); + DepthSizeInt := Round(Parser.Evaluate(DepthSize)); + for Y := Low(Structure[2]) to High(Structure[2]) do begin - Funcs^.ReadFuture(Instance, StreamPosInt2 + OldSizeInt, - Structure[2, Y].Data, Structure[2, Y].Size); - I64 := 0; - EndianMove(Structure[2, Y].Data, @I64, - Min(Structure[2, Y].Size, I64.Size), BigEndian); - Structure[2, Y].Value := I64.ToDouble; - Inc(StreamPosInt2, Structure[2, Y].Size); + if (Structure[2, Y].BeforeStream = False) then + begin + Funcs^.ReadFuture(Instance, StreamPosInt2 + OldSizeInt, + Structure[2, Y].Data, Structure[2, Y].Size); + I64 := 0; + EndianMove(Structure[2, Y].Data, @I64, + Min(Structure[2, Y].Size, I64.Size), BigEndian); + Structure[2, Y].Value := I64.ToDouble; + Inc(StreamPosInt2, Structure[2, Y].Size); + end; end; - end; - if Length(Conditions) = 0 then - DoAddStream(CodecCfg[Instance, I, J]) - else - for Y := Low(Conditions) to High(Conditions) do - begin - if (Round(Parser.Evaluate(Conditions[Y])) <> 0) and - (Y = High(Conditions)) then - DoAddStream(CodecCfg[Instance, I, J]) - else + for Y := Low(Conditions[2]) to High(Conditions[2]) do + if Round(Parser.Evaluate(Conditions[2, Y])) = 0 then + begin + Status := TScanStatus.Fail; break; - end; + end; + end; + if Status = TScanStatus.None then + DoAddStream(CodecCfg[Instance, I, J]); UpdateCounters(CodecCfg[Instance, I, J]); for Y := Low(Counter) to High(Counter) do begin @@ -628,15 +644,25 @@ begin CfgRec^.DepthSize := ReadString('StreamList' + X.ToString, 'DepthSize', '0'); ConvertHexChr(CfgRec^.DepthSize); - Y := 1; - while ReadString('StreamList' + X.ToString, 'Condition' + Y.ToString, - '') <> '' do + for Z := Low(CfgRec^.Conditions) to High(CfgRec^.Conditions) do begin - S2 := ReadString('StreamList' + X.ToString, - 'Condition' + Y.ToString, ''); - ConvertHexChr(S2); - Insert(S2, CfgRec^.Conditions, Length(CfgRec^.Conditions)); - Inc(Y); + case Z of + 0: + S3 := 'Condition1_'; + 1: + S3 := 'ConditionN_'; + 2: + S3 := 'ConditionS_'; + end; + Y := 1; + while ReadString('StreamList' + X.ToString, S3 + Y.ToString, + '') <> '' do + begin + S2 := ReadString('StreamList' + X.ToString, S3 + Y.ToString, ''); + ConvertHexChr(S2); + Insert(S2, CfgRec^.Conditions[Z], Length(CfgRec^.Conditions[Z])); + Inc(Y); + end; end; ReadSectionValues('StreamList' + X.ToString, SL); for J := SL.Count - 1 downto 0 do diff --git a/precompressor/PrecompLZ4.pas b/precompressor/PrecompLZ4.pas index 2195d9f..dbe49e6 100644 --- a/precompressor/PrecompLZ4.pas +++ b/precompressor/PrecompLZ4.pas @@ -62,8 +62,8 @@ begin if (CompareText(S, LZ4Codecs[LZ4_CODEC]) = 0) and LZ4DLL.DLLLoaded then begin CodecEnabled[LZ4_CODEC] := True; - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); if Funcs^.GetParam(Command, X, 'a') <> '' then LAcceleration := StrToInt(Funcs^.GetParam(Command, X, 'a')); end @@ -75,8 +75,8 @@ begin for I := Low(SOList) to High(SOList) do SOList[I][LZ4HC_CODEC].Update ([StrToInt(Funcs^.GetParam(Command, X, 'l'))], True); - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); end else if (CompareText(S, LZ4Codecs[LZ4F_CODEC]) = 0) and LZ4DLL.DLLLoaded then @@ -86,8 +86,8 @@ begin for I := Low(SOList) to High(SOList) do SOList[I][LZ4F_CODEC].Update ([StrToInt(Funcs^.GetParam(Command, X, 'l'))], True); - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); if Funcs^.GetParam(Command, X, 'b') <> '' then LBlockSize := StrToInt(Funcs^.GetParam(Command, X, 'b')) - 4; if Funcs^.GetParam(Command, X, 'd') <> '' then @@ -232,34 +232,34 @@ begin (CodecEnabled[LZ4HC_CODEC] and (SOList[Instance][LZ4HC_CODEC].Count = 1)) then begin - Y := LZ4_decompress_safe(Input + Pos, Buffer, SizeEx - Pos, LMaxSize); - if Abs(Y) > 256 then + if (Input + Pos)^ in [$F0 .. $F3] then begin - try - X := LZ4_decompress_generic(Input + Pos, Buffer, SizeEx - Pos, Abs(Y), - Integer(endOnOutputSize)); - except - X := 0; - end; - // X := Abs(X); - Y := Abs(Y); - if (Round(X * 1.4) < Y) and (X < Y) and (X > 256) then + X := LZ4_decompress_generic(Input + Pos, Buffer, SizeEx - Pos, LMaxSize, + Integer(endOnOutputSize)); + if X > 256 then + Y := LZ4_decompress_safe(Input + Pos, Buffer, X, LMaxSize) + else + Y := 0; + if Y > 256 then begin - Output(Instance, Buffer, Y); - SI.Position := Pos; - SI.OldSize := X; - SI.NewSize := Y; - SI.Option := 0; - if CodecEnabled[LZ4_CODEC] then - SetBits(SI.Option, LZ4_CODEC, 0, 5) - else - SetBits(SI.Option, LZ4HC_CODEC, 0, 5); - SI.Status := TStreamStatus.None; - Funcs^.LogScan1(LZ4Codecs[GetBits(SI.Option, 0, 5)], SI.Position, - SI.OldSize, SI.NewSize); - Add(Instance, @SI, nil, nil); - Inc(Pos, 256); - continue; + if (X < Y) and (X > 256) then + begin + Output(Instance, Buffer, Y); + SI.Position := Pos; + SI.OldSize := X; + SI.NewSize := Y; + SI.Option := 0; + if CodecEnabled[LZ4_CODEC] then + SetBits(SI.Option, LZ4_CODEC, 0, 5) + else + SetBits(SI.Option, LZ4HC_CODEC, 0, 5); + SI.Status := TStreamStatus.None; + Funcs^.LogScan1(LZ4Codecs[GetBits(SI.Option, 0, 5)], SI.Position, + SI.OldSize, SI.NewSize); + Add(Instance, @SI, nil, nil); + Inc(Pos, 256); + continue; + end; end; end; end; diff --git a/precompressor/PrecompLZO.pas b/precompressor/PrecompLZO.pas index 335856d..a24680d 100644 --- a/precompressor/PrecompLZO.pas +++ b/precompressor/PrecompLZO.pas @@ -135,8 +135,8 @@ begin for I := Low(SOList) to High(SOList) do SOList[I][LZO1X_CODEC].Update ([StrToInt(Funcs^.GetParam(Command, X, 'l'))], True); - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); end else if (CompareText(S, LZOCodecs[LZO2A_CODEC]) = 0) and LZODLL.DLLLoaded then @@ -144,8 +144,8 @@ begin CodecEnabled[LZO2A_CODEC] := True; if Funcs^.GetParam(Command, X, 'v') = '999' then LZO2AVariant := 999; - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); end else if (CompareText(S, LZOCodecs[LZO1C_CODEC]) = 0) and LZODLL.DLLLoaded then @@ -153,8 +153,8 @@ begin CodecEnabled[LZO1C_CODEC] := True; if Funcs^.GetParam(Command, X, 'v') = '999' then LZO1CVariant := 999; - if Funcs^.GetParam(Command, X, 'm') <> '' then - LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + LMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); end; Inc(X); end; diff --git a/precompressor/PrecompMain.pas b/precompressor/PrecompMain.pas index 62a0645..166790d 100644 --- a/precompressor/PrecompMain.pas +++ b/precompressor/PrecompMain.pas @@ -6,14 +6,14 @@ interface uses InitCode, - Threading, Utils, SynCommons, ParseClass, ParseExpr, FLZMA2DLL, + Threading, Utils, SynCommons, ParseClass, ParseExpr, FLZMA2DLL, XXHASHLIB, PrecompUtils, PrecompCrypto, PrecompZLib, PrecompLZ4, PrecompLZO, PrecompZSTD, PrecompOodle, PrecompMedia, PrecompINI, PrecompINIEx, PrecompSearch, PrecompDLL, PrecompEXE, WinAPI.Windows, WinAPI.ShlObj, System.SysUtils, System.Classes, System.SyncObjs, System.Math, System.Types, System.StrUtils, System.RTLConsts, System.TimeSpan, System.Diagnostics, - System.Generics.Defaults, System.Generics.Collections; + System.Generics.Defaults, System.Generics.Collections, System.Character; const XTOOL_PRECOMP = $304C5458; @@ -27,18 +27,17 @@ type Depth: Integer; LowMem: Boolean; DBaseFile, ExtractDir: String; - DoCompress: Boolean; - CompressCfg: String; + CThreads, CLevel: Integer; + CDict: Integer; end; PDecodeOptions = ^TDecodeOptions; TDecodeOptions = record Method: String; - ChunkCount, Threads: Integer; + CacheSize, Threads: Integer; Depth: Integer; - DedupSysMem, DedupGPUMem: Int64; - CompressCfg: String; + DedupSysMem: Int64; end; procedure PrintHelp; @@ -74,12 +73,11 @@ procedure PrecompOutput3(Instance: Integer; const Buffer: Pointer; procedure PrecompAddStream(Instance: Integer; Info: PStrInfo1; Codec: PChar; DepthInfo: PDepthInfo)cdecl; procedure PrecompTransfer(Instance: Integer; Codec: PChar)cdecl; +function PrecompStorage(Instance: Integer; Size: PInteger): Pointer cdecl; +function PrecompAddResourceEx(Data: Pointer; Size: Integer): Integer cdecl; implementation -var - InternalSync: TCriticalSection; - procedure EncInit(Input, Output: TStream; Options: PEncodeOptions); forward; procedure EncFree; forward; function EncData(Input, Output: TStream; Index, Depth: Integer) @@ -92,12 +90,13 @@ procedure DecChunk(Input, Output: TStream; Index, Depth: Integer); forward; type TEncInfo = record Processed, Count: Integer; - DecMem0, DecMem1, DecMem2: Int64; + DecMem0, DecMem1, DecMem2, DecMem3: Int64; + DupSize1, DupSize2: Int64; + DupCount: Integer; + InSize, InflSize, SrepSize, CompSize: Int64; + SrepMem: Integer; end; -const - InternalMem: Int64 = 128 * 1024 * 1024; - var GlobalSync: TCriticalSection; ThreadSync: TArray; @@ -105,13 +104,17 @@ var Codecs: array of TPrecompressor; DBFile: String = ''; ExtDir: String = ''; - SrepMemCfg: String; + SrepInSize, SrepMemCfg: String; + ResCount: Integer; UseDB: Boolean = False; StoreDD: Integer = -2; VERBOSE: Boolean = False; EXTRACT: Boolean = False; NOVERIFY: Boolean = False; + COMPRESS: Boolean = False; + NULLOUT: Boolean = False; DupSysMem: Int64 = 0; + DecodeMemBlock: Int64 = 512 * 1024 * 1024; EncInfo: TEncInfo; EncFreed: Boolean = False; ConTask: TTask; @@ -133,22 +136,19 @@ begin ' -m# - codecs to use for precompression (separate with "+" if more than one)'); WriteLn(ErrOutput, ' -c# - scanning range of precompressor [16mb]'); WriteLn(ErrOutput, ' -t# - number of working threads [50p]'); - WriteLn(ErrOutput, ' -lm - low memory mode'); WriteLn(ErrOutput, ' -d# - scan depth [0]'); - WriteLn(ErrOutput, ''); - WriteLn(ErrOutput, 'Advanced parameters:'); + WriteLn(ErrOutput, ' -dd - use stream deduplication'); WriteLn(ErrOutput, - ' --dbase=# - use database (#=filename to save db, optional)'); - WriteLn(ErrOutput, ' --dedup - use stream deduplication'); + ' -l# - compress data using fast lzma2 (separate params with ":")'); + WriteLn(ErrOutput, ' d# - dictionary size'); + WriteLn(ErrOutput, ' -lm - low memory mode'); + WriteLn(ErrOutput, ' -s - skip stream verification'); + WriteLn(ErrOutput, ' -v - enables verbose'); + WriteLn(ErrOutput, ' -df# - set xdelta threshold to accept streams [5p]'); + WriteLn(ErrOutput, ' -x# - extract streams to directory path'); WriteLn(ErrOutput, - ' --mem=# - deduplication ram usage limit (#=size) [75p]'); - WriteLn(ErrOutput, - ' --diff=# - set xdelta threshold to accept streams [5p]'); - WriteLn(ErrOutput, ' --extract=# - extract streams to directory path'); - WriteLn(ErrOutput, - ' --compress=# - compress data using fast lzma2 (separate params with ":"'); - WriteLn(ErrOutput, ' l# - compression level [5]'); - WriteLn(ErrOutput, ' t# - number of threads [50p]'); + ' -dm# - deduplication memory usage limit (#=size) [75p]'); + WriteLn(ErrOutput, ' -sm# - srep memory usage limit (#=size) [75p]'); WriteLn(ErrOutput, ''); end; @@ -156,13 +156,15 @@ procedure Parse(ParamArg: TArray; out Options: TEncodeOptions); var ArgParse: TArgParser; ExpParse: TExpressionParser; - I: Integer; + List: TStringDynArray; + I, J: Integer; S: String; begin + FillChar(Options, SizeOf(TEncodeOptions), 0); + Options.Depth := 1; ArgParse := TArgParser.Create(ParamArg); ExpParse := TExpressionParser.Create; try - Options.Method := ''; I := 0; while True do begin @@ -183,42 +185,85 @@ begin S := ReplaceText(S, 'K', '* 1024^1'); S := ReplaceText(S, 'M', '* 1024^2'); S := ReplaceText(S, 'G', '* 1024^3'); - Options.ChunkSize := Max(4194304, Round(ExpParse.Evaluate(S))); + Options.ChunkSize := Max(4 * 1024 * 1024, Round(ExpParse.Evaluate(S))); S := ArgParse.AsString('-t', 0, '50p'); S := ReplaceText(S, 'p', '%'); S := ReplaceText(S, '%', '%*' + CPUCount.ToString); Options.Threads := Max(1, Round(ExpParse.Evaluate(S))); - Options.Depth := EnsureRange(Succ(ArgParse.AsInteger('-d', 0, 0)), 1, 10); - Options.LowMem := ArgParse.AsBoolean('-lm'); - UseDB := ArgParse.AsBoolean('-db') or ArgParse.AsBoolean('--dbase'); - Options.DBaseFile := ArgParse.AsString('--dbase=', 0, ''); - Options.DBaseFile := ArgParse.AsString('-db', 0, Options.DBaseFile); - if Options.DBaseFile <> '' then - UseDB := True; + { S := ArgParse.AsString('-b', 0, '512mb'); + S := ReplaceText(S, 'KB', '* 1024^1'); + S := ReplaceText(S, 'MB', '* 1024^2'); + S := ReplaceText(S, 'GB', '* 1024^3'); + S := ReplaceText(S, 'K', '* 1024^1'); + S := ReplaceText(S, 'M', '* 1024^2'); + S := ReplaceText(S, 'G', '* 1024^3'); + DecodeMemBlock := Max(32 * 1024 * 1024, Round(ExpParse.Evaluate(S))); } StoreDD := -2; - if ArgParse.AsBoolean('-dd') or ArgParse.AsBoolean('--dedup') then - StoreDD := -1; - if FileExists(ExpandPath(PluginsPath + 'srep.exe', True)) then + I := 0; + while True do begin - StoreDD := ArgParse.AsInteger('--dedup=', 0, StoreDD); - StoreDD := ArgParse.AsInteger('-dd', 0, StoreDD); + S := ArgParse.AsString('-d', I); + if S = '' then + break; + case S[1] of + 'b': + UseDB := True; + 'd': + begin + StoreDD := -1; + if FileExists(ExpandPath(PluginsPath + 'srep.exe', True)) then + if S.Length > 1 then + StoreDD := StrToInt(S[2]); + end; + 'f': + begin + S := ReplaceText(S.Substring(1), 'p', '%'); + DIFF_TOLERANCE := Max(0.00, ExpParse.Evaluate(S)); + end; + else + if S[1].IsDigit then + Options.Depth := EnsureRange(Succ(S.ToInteger), 1, 10); + end; + Inc(I); end; - S := ArgParse.AsString('--diff=', 0, '5p'); - S := ArgParse.AsString('-df', 0, S); - S := ReplaceText(S, 'p', '%'); - DIFF_TOLERANCE := Max(0.00, ExpParse.Evaluate(S)); - VERBOSE := ArgParse.AsBoolean('-v') or ArgParse.AsBoolean('--verbose'); - NOVERIFY := ArgParse.AsBoolean('-s') or ArgParse.AsBoolean('--skip'); - Options.ExtractDir := ArgParse.AsString('--extract='); + UseDB := True; + I := 0; + while True do + begin + S := ArgParse.AsString('-l', I); + if S = '' then + break; + case S[1] of + 'm': + Options.LowMem := True; + else + if S[1].IsDigit and FLZMA2DLL.DLLLoaded then + begin + S := ReplaceText(S, SPrecompSep3, SPrecompSep2); + if (S <> '') then + begin + List := DecodeStr(S, ':'); + Options.CThreads := Options.Threads; + Options.CLevel := StrToIntDef(List[0], 0); + for J := Low(List) to High(List) do + begin + if List[J].StartsWith('d', False) then + Options.CDict := EnsureRange(ConvertToBytes(List[J].Substring(1) + ), FL2_DICTSIZE_MIN, FL2_DICTSIZE_MAX); + end; + COMPRESS := InRange(Options.CLevel, 1, 10); + end; + end; + end; + Inc(I); + end; + SrepInSize := ArgParse.AsString('-SI', 0, '100gb').ToLower; + VERBOSE := ArgParse.AsBoolean('-v'); + NOVERIFY := ArgParse.AsBoolean('-s'); + OPTIMISE_DEC := ArgParse.AsBoolean('-o'); + Options.ExtractDir := ArgParse.AsString('-x'); if Options.ExtractDir <> '' then EXTRACT := DirectoryExists(Options.ExtractDir); - Options.DoCompress := ArgParse.AsBoolean('--compress') and - FLZMA2DLL.DLLLoaded; - S := ArgParse.AsString('--compress='); - S := ReplaceText(S, SPrecompSep3, SPrecompSep2); - Options.CompressCfg := S; - if Options.CompressCfg <> '' then - Options.DoCompress := FLZMA2DLL.DLLLoaded; finally ArgParse.Free; ExpParse.Free; @@ -238,11 +283,19 @@ begin ExpParse := TExpressionParser.Create; try Options.Method := ArgParse.AsString('-m'); + S := ArgParse.AsString('-c', 0, '64mb'); + S := ReplaceText(S, 'KB', '* 1024^1'); + S := ReplaceText(S, 'MB', '* 1024^2'); + S := ReplaceText(S, 'GB', '* 1024^3'); + S := ReplaceText(S, 'K', '* 1024^1'); + S := ReplaceText(S, 'M', '* 1024^2'); + S := ReplaceText(S, 'G', '* 1024^3'); + Options.CacheSize := Max(4 * 1024 * 1024, Round(ExpParse.Evaluate(S))); S := ArgParse.AsString('-t', 0, '50p'); S := ReplaceText(S, 'p', '%'); S := ReplaceText(S, '%', '%*' + CPUCount.ToString); Options.Threads := Max(1, Round(ExpParse.Evaluate(S))); - S := ArgParse.AsString('--mem=', 0, '75p'); + S := ArgParse.AsString('-dm', 0, '75p'); S := ReplaceText(S, 'KB', '* 1024^1'); S := ReplaceText(S, 'MB', '* 1024^2'); S := ReplaceText(S, 'GB', '* 1024^3'); @@ -255,11 +308,8 @@ begin Options.DedupSysMem := Max(0, Round(ExpParse.Evaluate(S))); if B then Options.DedupSysMem := -Options.DedupSysMem; - VERBOSE := ArgParse.AsBoolean('-v') or ArgParse.AsBoolean('--verbose'); - S := ArgParse.AsString('--compress=', 0, 't25p'); - S := ReplaceText(S, SPrecompSep3, SPrecompSep2); - Options.CompressCfg := S; - SrepMemCfg := ArgParse.AsString('--srepmem=', 0, '75p'); + SrepMemCfg := ArgParse.AsString('-sm', 0, '75p').ToLower; + VERBOSE := ArgParse.AsBoolean('-v'); finally ArgParse.Free; ExpParse.Free; @@ -268,27 +318,6 @@ begin Options.Threads := 1; end; -function GetIndex(Scanned, Processed: TArray): Integer; -var - I: Integer; -begin - if BoolArray(Processed, True) then - begin - Result := -2; - exit; - end - else - Result := -1; - for I := Low(Scanned) to High(Scanned) do - begin - if (Scanned[I] = True) and (Processed[I] = False) then - begin - Result := I; - break; - end; - end; -end; - type TCommonVarsEnc = record MemStream: TArray; @@ -316,7 +345,8 @@ var DepthInfo: TArray; ThrIdx: TArray; WorkStream: TArray; - Scanned1, Scanned2, Processed: TArray; + Scanned1, Scanned2, Processed, Helping: TArray; + DoScan2: Boolean; LogInt: Integer; LogInt64: Int64; LogPtr: Pointer; @@ -650,8 +680,8 @@ begin SI1.Codec := LCodec; SI1.Scan2 := False; SI1.Option := LOption; - SI1.Checksum := Utils.Hash32(0, PByte(DataStore.Slot(Instance).Memory) + - SI1.ActualPosition, SI1.OldSize); + PrecompHash('xxh3_128', PByte(DataStore.Slot(Instance).Memory) + + SI1.ActualPosition, SI1.OldSize, @SI1.Checksum, SizeOf(SI1.Checksum)); SI1.Status := Info^.Status; if Assigned(DepthInfo) then SI1.DepthInfo := DepthInfo^; @@ -675,11 +705,11 @@ begin I := (SI2.Position div IntArray[0]) mod IntArray[1] else I := Instance; - ThreadSync[I].Enter; + ThreadSync[I].Acquire; try InfoStore2[I, ISIndex[I].ToInteger].Add(SI2); finally - ThreadSync[I].Leave; + ThreadSync[I].Release; end; end; CurPos1[Instance] := MemOutput1[Instance].Position; @@ -692,6 +722,34 @@ begin CurTransfer[Instance] := String(Codec); end; +function PrecompStorage(Instance: Integer; Size: PInteger): Pointer; +begin + with ComVars1[CurDepth[Instance]] do + begin + Size^ := MemOutput1[Instance].Position - CurPos1[Instance]; + Result := PByte(MemOutput1[Instance].Memory) + CurPos1[Instance]; + end; +end; + +function PrecompAddResourceEx(Data: Pointer; Size: Integer): Integer; +var + I: Integer; +begin + Result := -1; + GlobalSync.Acquire; + try + I := Length(Resources); + SetLength(Resources, Succ(I)); + Resources[I].Name := Utils.Hash32(0, Data, Size).ToHexString; + Resources[I].Size := Size; + GetMem(Resources[I].Data, Resources[I].Size); + Move(Data^, Resources[I].Data^, Resources[I].Size); + Result := I; + finally + GlobalSync.Release; + end; +end; + function CheckDB(StreamInfo: TEncodeSI; Database: PDatabase): Boolean; var A: Word; @@ -700,13 +758,13 @@ var DB: PDatabase; begin Result := False; - A := LongRec(StreamInfo.Checksum).Lo; + Move(StreamInfo.Checksum, A, A.Size); AtomicExchange(LCount, DBCount[A]); for I := 0 to LCount - 1 do begin DB := @DBInfo[A, I]; - if (DB^.Size = StreamInfo.OldSize) and (DB^.Checksum = StreamInfo.Checksum) - then + if (DB^.Size = StreamInfo.OldSize) and CompareMem(@DB^.Checksum, + @StreamInfo.Checksum, SizeOf(DB^.Checksum)) then begin if Assigned(Database) then Move(DB^, Database^, SizeOf(TDatabase)); @@ -722,7 +780,7 @@ var I: Integer; DB: TDatabase; begin - A := LongRec(StreamInfo.Checksum).Lo; + Move(StreamInfo.Checksum, A, A.Size); if not CheckDB(StreamInfo, nil) then begin GlobalSync.Acquire; @@ -730,7 +788,7 @@ begin DB.Size := StreamInfo.OldSize; DB.Codec := StreamInfo.Codec; DB.Option := StreamInfo.Option; - DB.Checksum := StreamInfo.Checksum; + Move(StreamInfo.Checksum, DB.Checksum, SizeOf(DB.Checksum)); DB.Status := StreamInfo.Status; Insert(DB, DBInfo[A], Length(DBInfo[A])); Inc(DBCount[A]); @@ -749,13 +807,13 @@ var DD: PDuplicate1; begin Result := False; - A := LongRec(StreamInfo.Checksum).Lo; + Move(StreamInfo.Checksum, A, A.Size); LCount := DDCount1[A]; for I := 0 to LCount - 1 do begin DD := @DDInfo[A, I]; - if (DD^.Size = StreamInfo.OldSize) and (DD^.Checksum = StreamInfo.Checksum) - then + if (DD^.Size = StreamInfo.OldSize) and CompareMem(@DD^.Checksum, + @StreamInfo.Checksum, SizeOf(DD^.Checksum)) then begin if Assigned(Database) then Move(DD^, Database^, SizeOf(TDuplicate1)); @@ -776,7 +834,7 @@ begin Result := False; if CheckDD(StreamInfo, nil, @I) then begin - A := LongRec(StreamInfo.Checksum).Lo; + Move(StreamInfo.Checksum, A, A.Size); DD := @DDInfo[A, I]; if Assigned(Index) then Index^ := DD^.Index; @@ -795,11 +853,11 @@ var begin Result := False; Inc(DDIndex); - A := LongRec(StreamInfo.Checksum).Lo; + Move(StreamInfo.Checksum, A, A.Size); if not CheckDD(StreamInfo, nil, @I) then begin DD.Size := StreamInfo.OldSize; - DD.Checksum := StreamInfo.Checksum; + Move(StreamInfo.Checksum, DD.Checksum, SizeOf(DD.Checksum)); DD.Index := DDIndex; DD.Count := 0; I := Length(DDInfo[A]); @@ -924,9 +982,9 @@ begin SI3.Scan2 := False; SI3.Option := SI1.Option; SI3.Status := SI1.Status; - SI3.Checksum := - Utils.Hash32(0, PByte(DataStore.Slot(Index).Memory) + - SI3.ActualPosition, SI3.OldSize); + PrecompHash('xxh3_128', PByte(DataStore.Slot(Index).Memory) + + SI3.ActualPosition, SI3.OldSize, @SI3.Checksum, + SizeOf(SI3.Checksum)); SI3.DepthInfo := SI2.DepthInfo; InfoStore1[Index].Add(SI3); end @@ -1080,12 +1138,12 @@ begin try if EncData(nil, MemOutput3[Index], Index, Succ(Depth)) then begin - ThreadSync[Index].Enter; + ThreadSync[Index].Acquire; try MemOutput2[Index].WriteBuffer(MemOutput3[Index].Memory^, MemOutput3[Index].Position); finally - ThreadSync[Index].Leave; + ThreadSync[Index].Release; end; SI2.StorePosition := CurPos2[Index]; SI2.NewSize := MemOutput2[Index].Position - CurPos2[Index]; @@ -1106,7 +1164,76 @@ begin end; end; +procedure EncThreadEx(ThreadIndex, Index, Depth: IntPtr); +var + X: Integer; +begin + with ComVars1[Depth] do + begin + try + X := AtomicIncrement(StrIdx[ThreadIndex]); + while X < InfoStore1[ThreadIndex].Count do + begin + Process(ThreadIndex, X, Index, Depth); + X := AtomicIncrement(StrIdx[ThreadIndex]); + end; + finally + ThreadSync[Index].Acquire; + try + Helping[Index] := False; + finally + ThreadSync[Index].Release; + end; + end; + end; +end; + +procedure EncCallThreads(ThreadIndex, Index, Depth: Integer); +var + I: Integer; +begin + for I := Low(Tasks) to High(Tasks) do + if I <> Index then + begin + ThreadSync[I].Acquire; + try + if (Tasks[I].Status = TThreadStatus.tsReady) and (Processed[I] = True) + and (Helping[I] = False) then + begin + Helping[I] := True; + Tasks[I].Update(ThreadIndex, I, Depth); + Tasks[I].Perform(EncThreadEx); + Tasks[I].Start; + end; + finally + ThreadSync[I].Release; + end; + end; +end; + procedure EncThread(Y, W: IntPtr); + + function GetIndex: Integer; + var + I: Integer; + begin + if BoolArray(Processed, True) then + begin + Result := -2; + exit; + end + else + Result := -1; + for I := Low(Scanned2) to High(Scanned2) do + begin + if (Scanned2[I] = True) and (Processed[I] = False) then + begin + Result := I; + break; + end; + end; + end; + var X, Z: Integer; begin @@ -1126,10 +1253,12 @@ begin if W = 0 then begin Scanned1[Y] := True; - while not BoolArray(Scanned1, True) do - Sleep(10); + if DoScan2 then + while not BoolArray(Scanned1, True) do + Sleep(10); end; - Scan2(Y, W); + if DoScan2 then + Scan2(Y, W); InfoStore1[Y].Sort; if W = 0 then Scanned2[Y] := True; @@ -1138,11 +1267,11 @@ begin begin if W = 0 then begin - Z := GetIndex(Scanned2, Processed); + Z := GetIndex; while Z = -1 do begin Sleep(10); - Z := GetIndex(Scanned2, Processed); + Z := GetIndex; end; ThrIdx[Y] := Z; if Z < -1 then @@ -1159,14 +1288,16 @@ begin X := AtomicIncrement(StrIdx[Z]); while X < InfoStore1[Z].Count do begin + if (Succ(W) = Length(ComVars1)) and (Length(Tasks) > 1) then + EncCallThreads(Z, Y, W); Process(Z, X, Y, W); if W = 0 then begin - Z := GetIndex(Scanned2, Processed); + Z := GetIndex; while Z = -1 do begin Sleep(10); - Z := GetIndex(Scanned2, Processed); + Z := GetIndex; end; ThrIdx[Y] := Z; if Z < -1 then @@ -1174,6 +1305,8 @@ begin end; X := AtomicIncrement(StrIdx[Z]); end; + while not BoolArray(Helping, False) do + Sleep(10); if VERBOSE and (InfoStore1[Z].Count > 0) then WriteLn(ErrOutput, ''); if W = 0 then @@ -1193,6 +1326,7 @@ procedure EncInit(Input, Output: TStream; Options: PEncodeOptions); var UI32: UInt32; I, J, K: Integer; + B: Byte; W: Word; Bytes: TBytes; NI: NativeInt; @@ -1230,7 +1364,7 @@ begin for I := Low(Tasks) to High(Tasks) do begin if Length(Tasks) > 1 then - Tasks[I] := TTask.Create(I, 0); + Tasks[I] := TTask.Create; FillChar(DepthInfo[I], SizeOf(TDepthInfo), 0); WorkStream[I] := TMemoryStream.Create; end; @@ -1241,6 +1375,7 @@ begin SetLength(Scanned1, I); SetLength(Scanned2, I); SetLength(Processed, I); + SetLength(Helping, I); SetLength(ComVars1, Options^.Depth); for J := Low(ComVars1) to High(ComVars1) do with ComVars1[J] do @@ -1317,6 +1452,22 @@ begin end; ExtDir := IncludeTrailingBackSlash(Options^.ExtractDir); Output.WriteBuffer(Options^.Depth, Options^.Depth.Size); + DoScan2 := True; + for J := 0 to ExternalMethods.Count - 1 do + begin + I := 0; + while PrecompGetCodec(PChar(Options^.Method), I, False) <> '' do + begin + if PrecompGetCodec(PChar(S), I, False) = ExternalMethods[J] then + begin + DoScan2 := True; + break; + end; + Inc(I); + end; + if DoScan2 then + break; + end; S := ''; I := 0; while PrecompGetCodec(PChar(Options^.Method), I, False) <> '' do @@ -1354,20 +1505,21 @@ begin S := S + SPrecompSep1 + ExternalMethods[J]; end; Bytes := BytesOf(S); - LongRec(I).Bytes[0] := Length(Bytes); - Output.WriteBuffer(LongRec(I).Bytes[0], LongRec(I).Bytes[0].Size); - Output.WriteBuffer(Bytes[0], LongRec(I).Bytes[0]); + B := Length(Bytes); + Output.WriteBuffer(B, B.Size); + Output.WriteBuffer(Bytes[0], B); I := Length(Resources); Output.WriteBuffer(I, I.Size); for J := Low(Resources) to High(Resources) do begin Bytes := BytesOf(Resources[J].Name); - LongRec(I).Bytes[0] := Length(Bytes); - Output.WriteBuffer(LongRec(I).Bytes[0], LongRec(I).Bytes[0].Size); - Output.WriteBuffer(Bytes[0], LongRec(I).Bytes[0]); + B := Length(Bytes); + Output.WriteBuffer(B, B.Size); + Output.WriteBuffer(Bytes[0], B); Output.WriteBuffer(Resources[J].Size, Resources[J].Size.Size); Output.WriteBuffer(Resources[J].Data^, Resources[J].Size); end; + ResCount := Length(Resources); Output.WriteBuffer(StoreDD, StoreDD.Size); end; @@ -1422,8 +1574,6 @@ function EncData(Input, Output: TStream; Index, Depth: Integer): Boolean; Result := fmCreate; end; -const - DecMemLimit = 384 * 1024 * 1024; var TempOutput: TStream; StreamInfo: TEncodeSI; @@ -1441,10 +1591,54 @@ var DupBool: Boolean; DupIdx1, DupIdx2, DupCount: Integer; DupTyp: TDuplicate2; + ErrStream: TStringStream; + + procedure SaveResources; + var + C, D: Integer; + B: Byte; + Bytes: TBytes; + begin + if Depth = 0 then + begin + GlobalSync.Acquire; + try + C := Length(Resources) - ResCount; + TempOutput.WriteBuffer(C, C.Size); + for D := ResCount to High(Resources) do + begin + Bytes := BytesOf(Resources[D].Name); + B := Length(Bytes); + TempOutput.WriteBuffer(B, B.Size); + TempOutput.WriteBuffer(Bytes[0], B); + TempOutput.WriteBuffer(Resources[D].Size, Resources[D].Size.Size); + TempOutput.WriteBuffer(Resources[D].Data^, Resources[D].Size); + end; + ResCount := Length(Resources); + finally + GlobalSync.Release; + end; + end; + end; + begin if (Depth = 0) then begin - if StoreDD > -2 then + ErrStream := TStringStream.Create; + if NULLOUT then + begin + if StoreDD > 0 then + begin + TempOutput := TBufferedStream.Create + (TProcessStream.Create(ExpandPath(PluginsPath + 'srep.exe', True), + '-m' + StoreDD.ToString + ' -s' + SrepInSize + ' - -', GetCurrentDir, + nil, Output, ErrStream), False, 4194304); + TProcessStream(TBufferedStream(TempOutput).Instance).Execute; + end + else + TempOutput := Output; + end + else if StoreDD > -2 then TempOutput := TBufferedStream.Create (TFileStream.Create (LowerCase(ChangeFileExt(ExtractFileName(Utils.GetModuleName), @@ -1478,6 +1672,7 @@ begin Scanned1[I] := False; Scanned2[I] := False; Processed[I] := False; + Helping[I] := False; end; end; for I := Low(Tasks) to High(Tasks) do @@ -1493,6 +1688,7 @@ begin CurTransfer[I] := ''; if (Depth = 0) and (Length(Tasks) > 1) then begin + Tasks[I].Update(I, Depth); Tasks[I].Perform(EncThread); Tasks[I].Start; end @@ -1503,6 +1699,7 @@ begin begin if Depth = 0 then begin + Inc(EncInfo.InSize, TDataStore1(DataStore).Size(I)); while Processed[I] = False do begin if Length(Tasks) > 1 then @@ -1556,8 +1753,14 @@ begin DupBool := not FindOrAddDD(StreamInfo, @DupIdx2, @DupCount); if DupBool then begin + Inc(EncInfo.DupCount); if DupCount = 1 then + begin Inc(EncInfo.DecMem2, StreamInfo.OldSize); + Inc(EncInfo.DecMem3, StreamInfo.NewSize + StreamInfo.ExtSize); + end; + Inc(EncInfo.DupSize1, StreamInfo.OldSize); + Inc(EncInfo.DupSize2, StreamInfo.NewSize + StreamInfo.ExtSize); FillChar(StreamHeader, SizeOf(TStreamHeader), 0); StreamHeader.Kind := DUPLICATED_STREAM; StreamHeader.Option := DupIdx2; @@ -1588,7 +1791,7 @@ begin LastStream := Int64(StreamInfo.ActualPosition) + StreamInfo.OldSize; end; - if CurrSize >= DecMemLimit then + if (Depth = 0) and (CurrSize >= DecodeMemBlock) then break; J := InfoStore1[I].Get(StreamInfo); end; @@ -1601,7 +1804,10 @@ begin MemStream[I].Position := 0; MemStream[I].WriteBuffer(StreamCount, StreamCount.Size); MemStream[I].WriteBuffer(BlockSize, BlockSize.Size); + SaveResources; TempOutput.WriteBuffer(MemStream[I].Memory^, I64); + if Depth = 0 then + Inc(EncInfo.InflSize, I64); InfoStore1[I].Index := LastIndex; J := InfoStore1[I].Get(StreamInfo); while J >= 0 do @@ -1613,19 +1819,21 @@ begin begin if StreamInfo.ExtSize < 0 then begin - ThreadSync[StreamInfo.Thread].Enter; + ThreadSync[StreamInfo.Thread].Acquire; try TempOutput.WriteBuffer ((PByte(MemOutput2[StreamInfo.Thread].Memory) + StreamInfo.StorePosition)^, StreamInfo.NewSize); finally - ThreadSync[StreamInfo.Thread].Leave; + ThreadSync[StreamInfo.Thread].Release; end; end else TempOutput.WriteBuffer ((PByte(MemOutput1[StreamInfo.Thread].Memory) + StreamInfo.StorePosition)^, StreamInfo.NewSize); + if Depth = 0 then + Inc(EncInfo.InflSize, StreamInfo.NewSize); if StreamInfo.ExtSize > 0 then begin TempOutput.WriteBuffer @@ -1633,6 +1841,9 @@ begin StreamInfo.ExtPosition)^, StreamInfo.ExtSize); TempOutput.WriteBuffer(StreamInfo.ExtSize, StreamInfo.ExtSize.Size); + if Depth = 0 then + Inc(EncInfo.InflSize, StreamInfo.ExtSize + + StreamInfo.ExtSize.Size); end; end; Inc(DupIdx1); @@ -1649,6 +1860,8 @@ begin if UI32 > 0 then TempOutput.WriteBuffer ((PByte(DataStore.Slot(I).Memory) + LastPos)^, UI32); + if Depth = 0 then + Inc(EncInfo.InflSize, UI32 + UI32.Size); LastPos := StreamInfo.ActualPosition + StreamInfo.OldSize; if Succ(J - LastIndex) = StreamCount then break; @@ -1663,16 +1876,22 @@ begin if UI32 > 0 then TempOutput.WriteBuffer ((PByte(DataStore.Slot(I).Memory) + LastPos)^, UI32); + if Depth = 0 then + Inc(EncInfo.InflSize, UI32 + UI32.Size); until LastIndex = InfoStore1[I].Count; LastStream := Max(LastStream - DataStore.Size(I), 0); if Depth = 0 then - begin if I > 0 then TDataStore1(DataStore).LoadEx; - end; end; if Depth = 0 then begin + if NULLOUT then + if StoreDD > 0 then + EncInfo.SrepSize := TProcessStream(TBufferedStream(TempOutput) + .Instance).OutSize; + if COMPRESS then + EncInfo.CompSize := TLZMACompressStream(Output).OutSize; TDataStore1(DataStore).LoadEx; if Length(Tasks) > 1 then WaitForAll(Tasks); @@ -1680,8 +1899,11 @@ begin else break; end; + SaveResources; StreamCount := StreamCount.MinValue; TempOutput.WriteBuffer(StreamCount, StreamCount.Size); + if Depth = 0 then + Inc(EncInfo.InflSize, StreamCount.Size); end; if Depth = 0 then begin @@ -1733,33 +1955,64 @@ begin EncFree; finally end; - S := TFileStream(TBufferedStream(TempOutput).Instance).Filename; - TBufferedStream(TempOutput).Flush; - if StoreDD >= 0 then + if NULLOUT then begin - with TProcessStream.Create(ExpandPath(PluginsPath + 'srep.exe', True), - '-m' + StoreDD.ToString + 'f ' + S + ' -', GetCurrentDir, nil, - Output) do - try - if Execute then - begin - Wait; - Done; - end; - finally - Free; - end; + if StoreDD > 0 then + begin + TBufferedStream(TempOutput).Flush; + TProcessStream(TBufferedStream(TempOutput).Instance) + .WriteBuffer(StoreDD, 0); + TProcessStream(TBufferedStream(TempOutput).Instance).Wait; + TProcessStream(TBufferedStream(TempOutput).Instance).Done; + TempOutput.Free; + end; end else - Output.CopyFrom(TBufferedStream(TempOutput).Instance, 0); - TempOutput.Free; - DeleteFile(S); + begin + S := TFileStream(TBufferedStream(TempOutput).Instance).FileName; + TBufferedStream(TempOutput).Flush; + if StoreDD > 0 then + begin + with TProcessStream.Create(ExpandPath(PluginsPath + 'srep.exe', True), + '-m' + StoreDD.ToString + 'f ' + S + ' -', GetCurrentDir, nil, + Output, ErrStream) do + try + if Execute then + begin + while Running do + begin + EncInfo.SrepSize := OutSize; + Sleep(100); + end; + Done; + EncInfo.SrepSize := OutSize; + end; + finally + Free; + end; + end + else + Output.CopyFrom(TBufferedStream(TempOutput).Instance, 0); + TempOutput.Free; + DeleteFile(S); + end; end else try EncFree; finally end; + S := 'Decompression memory is '; + I := ErrStream.DataString.IndexOf(S); + J := 0; + if I > 0 then + begin + while ErrStream.DataString.Substring(I + S.Length + J, 1) <> ' ' do + Inc(J); + EncInfo.SrepMem := ErrStream.DataString.Substring(I + S.Length, J) + .ToInteger; + end; + ErrStream.Free; end; end; @@ -1784,6 +2037,7 @@ type StreamCount: TArray; StreamInfo: TArray; StreamIdx: TArray; + BlockPos: TArray; end; procedure TStreamInfo.Init; @@ -1823,7 +2077,7 @@ var DDList2: TArray; DDCount2: Integer; DDIndex1, DDIndex2: Integer; - BlockPos: Int64; + CacheSize: Integer; procedure PrecompOutput2(Instance: Integer; const Buffer: Pointer; Size: Integer); @@ -1832,7 +2086,10 @@ begin DecOutput[Instance].WriteBuffer(Buffer^, Size); if (StoreDD > -2) and (CurDepth[Instance] = 0) then if ((DDIndex2 < DDCount2) and (DDIndex1 = DDList2[DDIndex2].Index)) then + begin + NStream.Update(0, NStream.MaxSize(0) + CalcSysMem); DataMgr.Write(DDIndex1, Buffer, Size); + end; end; procedure PrecompOutput3(Instance: Integer; const Buffer: Pointer; @@ -1842,7 +2099,30 @@ begin MemOutput1[Instance].WriteBuffer(Buffer^, Size); end; -procedure Restore(MT: Boolean; Index, Depth: Integer); +procedure DecThread(X, Y, Z: IntPtr); forward; + +procedure DecCallThreads(Index, Depth: Integer); +var + I: Integer; +begin + for I := Low(Tasks) to High(Tasks) do + if I <> Index then + begin + ThreadSync[I].Acquire; + try + if Tasks[I].Status = TThreadStatus.tsReady then + begin + Tasks[I].Update(Index, I, Depth); + Tasks[I].Perform(DecThread); + Tasks[I].Start; + end; + finally + ThreadSync[I].Release; + end; + end; +end; + +procedure Restore(MT: Boolean; Index1, Index2, Depth: Integer); var X, Y: Integer; Pos: Int64; @@ -1855,23 +2135,26 @@ var begin with ComVars2[Depth] do begin + CurDepth[Index2] := Depth; Pos := 0; - X := AtomicIncrement(StreamIdx[Index]^); - while X < StreamCount[Index]^ do + X := AtomicIncrement(StreamIdx[Index1]^); + while X < StreamCount[Index1]^ do begin - SH := PStreamHeader(MemStream1[Index].Memory) + X; + if (Succ(Depth) = Length(ComVars2)) and (Length(Tasks) > 1) then + DecCallThreads(Index1, Depth); + SH := PStreamHeader(MemStream1[Index1].Memory) + X; if MT then begin LOutput := @PrecompOutput3; - Pos := StreamInfo[Index]^.Pos[X]; + Pos := StreamInfo[Index1]^.Pos[X]; X64 := Pos + Max(SH^.OldSize, SH^.NewSize); - while (BlockPos < X64) do + while (BlockPos[Index1]^ < X64) do begin - if IsErrored(Tasks) or (BlockPos < 0) then + if IsErrored(Tasks) or (BlockPos[Index1]^ < 0) then exit; Sleep(1); end; - MemOutput1[Index].Position := 0; + MemOutput1[Index2].Position := 0; end else begin @@ -1883,60 +2166,59 @@ begin DataMgr.Add(DDIndex1, SH^.OldSize, DDList2[DDIndex2].Count); end; LOutput := @PrecompOutput2; - DecInput[Index].ReadBuffer(UI32, UI32.Size); + DecInput[Index1].ReadBuffer(UI32, UI32.Size); if UI32 > 0 then - CopyStreamEx(DecInput[Index], DecOutput[Index], UI32); + CopyStreamEx(DecInput[Index1], DecOutput[Index1], UI32); end; SI.OldSize := SH^.OldSize; SI.NewSize := SH^.NewSize; SI.Resource := SH^.Resource; SI.Option := SH^.Option; - Ptr1 := PByte(MemInput[Index].Memory) + Pos; + Ptr1 := PByte(MemInput[Index1].Memory) + Pos; if SH^.Kind and EXTENDED_STREAM = EXTENDED_STREAM then begin SI.ExtSize := PInteger(Ptr1 + SI.NewSize - SI.NewSize.Size)^; SI.NewSize := SI.NewSize - SI.ExtSize - SI.ExtSize.Size; - Ptr2 := PByte(MemInput[Index].Memory) + Pos + SI.NewSize; + Ptr2 := PByte(MemInput[Index1].Memory) + Pos + SI.NewSize; end else Ptr2 := nil; if SH^.Kind and NESTED_STREAM = NESTED_STREAM then begin - MemStream2[Index].Update(Ptr1, SI.NewSize); - MemStream2[Index].Size := SI.NewSize; - MemStream2[Index].Position := 0; - MemOutput2[Index].Position := 0; - DecChunk(MemStream2[Index], MemOutput2[Index], Index, Succ(Depth)); - SI.NewSize := PInteger(MemOutput2[Index].Memory)^; - Ptr1 := PByte(MemOutput2[Index].Memory) + SI.NewSize.Size; - SI.ExtSize := PInteger(PByte(MemOutput2[Index].Memory) + SI.NewSize.Size - + SI.NewSize)^; - Ptr2 := PByte(MemOutput2[Index].Memory) + SI.NewSize.Size + SI.NewSize + - SI.ExtSize.Size; + MemStream2[Index2].Update(Ptr1, SI.NewSize); + MemStream2[Index2].Size := SI.NewSize; + MemStream2[Index2].Position := 0; + MemOutput2[Index2].Position := 0; + DecChunk(MemStream2[Index2], MemOutput2[Index2], Index2, Succ(Depth)); + SI.NewSize := PInteger(MemOutput2[Index2].Memory)^; + Ptr1 := PByte(MemOutput2[Index2].Memory) + SI.NewSize.Size; + SI.ExtSize := PInteger(PByte(MemOutput2[Index2].Memory) + + SI.NewSize.Size + SI.NewSize)^; + Ptr2 := PByte(MemOutput2[Index1].Memory) + SI.NewSize.Size + SI.NewSize + + SI.ExtSize.Size; end; if SH^.Kind and DUPLICATED_STREAM = DUPLICATED_STREAM then begin if MT then - StreamInfo[Index]^.Completed[X] := True + StreamInfo[Index1]^.Completed[X] := True else - DataMgr.CopyData(SH^.Option, DecOutput[Index]); - X := AtomicIncrement(StreamIdx[Index]^); + DataMgr.CopyData(SH^.Option, DecOutput[Index1]); + X := AtomicIncrement(StreamIdx[Index1]^); continue; end; - CurCodec[Index] := SH^.Codec; - CurDepth[Index] := Depth; + CurCodec[Index1] := SH^.Codec; + CurDepth[Index1] := Depth; Y := GetBits(SI.Option, 0, 5); if not InRange(Y, 0, Pred(Length(Codecs[SH^.Codec].Names))) then Y := 0; - if (Codecs[SH^.Codec].Restore(Index, Depth, Ptr1, Ptr2, SI, LOutput, + if (Codecs[SH^.Codec].Restore(Index2, Depth, Ptr1, Ptr2, SI, LOutput, @PrecompFunctions) = False) then raise Exception.CreateFmt(SPrecompError3, [Codecs[SH^.Codec].Names[Y]]); - NStream.Update(0, CalcSysMem); if MT then begin - Ptr1 := PByte(MemInput[Index].Memory) + Pos; - Move(MemOutput1[Index].Memory^, Ptr1^, SI.OldSize); - StreamInfo[Index]^.Completed[X] := True; + Ptr1 := PByte(MemInput[Index1].Memory) + Pos; + Move(MemOutput1[Index2].Memory^, Ptr1^, SI.OldSize); + StreamInfo[Index1]^.Completed[X] := True; end else begin @@ -1946,24 +2228,20 @@ begin Inc(DDIndex2); Inc(Pos, SH^.NewSize); end; - X := AtomicIncrement(StreamIdx[Index]^); + X := AtomicIncrement(StreamIdx[Index1]^); end; end; end; -procedure DecThread(Y, Z: IntPtr); +procedure DecThread(X, Y, Z: IntPtr); begin - Restore(True, Y, Z); -end; - -procedure DecReadCB(Pos: Int64); -begin - BlockPos := Pos; + Restore(True, X, Y, Z); end; procedure DecInit(Input, Output: TStream; Options: PDecodeOptions); var - I, J: Integer; + I, J, K: Integer; + B: Byte; Bytes: TBytes; UI32: UInt32; DupTyp: TDuplicate1; @@ -1977,31 +2255,33 @@ begin NStream.Add(TypeInfo(TMemoryStream), CalcSysMem); NStream.Add(TypeInfo(TPrecompVMStream)); Input.ReadBuffer(Options^.Depth, Options^.Depth.Size); - Input.ReadBuffer(LongRec(I).Bytes[0], LongRec(I).Bytes[0].Size); - SetLength(Bytes, LongRec(I).Bytes[0]); - Input.ReadBuffer(Bytes[0], LongRec(I).Bytes[0]); + Input.ReadBuffer(B, B.Size); + SetLength(Bytes, B); + Input.ReadBuffer(Bytes[0], B); Options^.Method := StringOf(Bytes); + CacheSize := Options^.CacheSize; Input.ReadBuffer(I, I.Size); for J := 0 to I - 1 do begin - Input.ReadBuffer(LongRec(I).Bytes[0], LongRec(I).Bytes[0].Size); - SetLength(Bytes, LongRec(I).Bytes[0]); - Input.ReadBuffer(Bytes[0], LongRec(I).Bytes[0]); + Input.ReadBuffer(B, B.Size); + SetLength(Bytes, B); + Input.ReadBuffer(Bytes[0], B); LResData.Name := StringOf(Bytes); Input.ReadBuffer(LResData.Size, LResData.Size.Size); GetMem(LResData.Data, LResData.Size); Input.ReadBuffer(LResData.Data^, LResData.Size); Insert(LResData, Resources, Length(Resources)); end; - SetLength(Tasks, Options^.Threads); + if Options^.Threads > 1 then + SetLength(Tasks, Options^.Threads); SetLength(CurCodec, Options^.Threads); SetLength(CurDepth, Options^.Threads); SetLength(DepthInfo, Options^.Threads); SetLength(WorkStream, Options^.Threads); - for I := Low(Tasks) to High(Tasks) do + for I := Low(ThreadSync) to High(ThreadSync) do begin if Length(Tasks) > 1 then - Tasks[I] := TTask.Create(I, 0); + Tasks[I] := TTask.Create; FillChar(DepthInfo[I], SizeOf(TDepthInfo), 0); WorkStream[I] := TMemoryStream.Create; end; @@ -2020,7 +2300,8 @@ begin SetLength(StreamCount, Options^.Threads); SetLength(StreamInfo, Options^.Threads); SetLength(StreamIdx, Options^.Threads); - for I := Low(Tasks) to High(Tasks) do + SetLength(BlockPos, Options^.Threads); + for I := Low(ThreadSync) to High(ThreadSync) do begin if (J = 0) and (I > 0) then begin @@ -2029,6 +2310,7 @@ begin StreamCount[I] := StreamCount[0]; StreamInfo[I] := StreamInfo[0]; StreamIdx[I] := StreamIdx[0]; + BlockPos[I] := BlockPos[0]; end else begin @@ -2038,6 +2320,7 @@ begin New(StreamInfo[I]); StreamInfo[I]^.Init; New(StreamIdx[I]); + New(BlockPos[I]); end; MemStream2[I] := TMemoryStreamEx.Create(False); MemOutput1[I] := TMemoryStream.Create; @@ -2052,13 +2335,12 @@ procedure DecFree; var I, J: Integer; begin - if Length(Tasks) > 1 then - WaitForAll(Tasks); - CodecFree(Length(Tasks)); + WaitForAll(Tasks); + CodecFree(Length(ThreadSync)); for J := Low(ComVars2) to High(ComVars2) do with ComVars2[J] do begin - for I := Low(Tasks) to High(Tasks) do + for I := Low(ThreadSync) to High(ThreadSync) do begin MemStream2[I].Free; MemOutput1[I].Free; @@ -2071,9 +2353,10 @@ begin StreamInfo[I]^.Free; Dispose(StreamInfo[I]); Dispose(StreamIdx[I]); + Dispose(BlockPos[I]); end; end; - for I := Low(Tasks) to High(Tasks) do + for I := Low(ThreadSync) to High(ThreadSync) do begin if Length(Tasks) > 1 then Tasks[I].Free; @@ -2094,6 +2377,33 @@ var UI32: UInt32; I, J: Integer; LStream: TProcessStream; + procedure LoadResources; + var + C, D: Integer; + B: Byte; + Bytes: TBytes; + LResData: TResData; + begin + with ComVars2[Depth] do + begin + if Depth = 0 then + begin + DecInput[Index].ReadBuffer(C, C.Size); + for D := 0 to C - 1 do + begin + DecInput[Index].ReadBuffer(B, B.Size); + SetLength(Bytes, B); + DecInput[Index].ReadBuffer(Bytes[0], B); + LResData.Name := StringOf(Bytes); + DecInput[Index].ReadBuffer(LResData.Size, LResData.Size.Size); + GetMem(LResData.Data, LResData.Size); + DecInput[Index].ReadBuffer(LResData.Data^, LResData.Size); + Insert(LResData, Resources, Length(Resources)); + end; + end; + end; + end; + begin if Depth = 0 then begin @@ -2112,35 +2422,37 @@ begin end; with ComVars2[Depth] do begin - if (Depth = 0) and (StoreDD >= 0) then + if (Depth = 0) and (StoreDD > 0) then begin LStream := TProcessStream.Create(ExpandPath(PluginsPath + 'srep.exe', True), '-d -s -mem' + SrepMemCfg + ' - -', GetCurrentDir, Input, nil); if not LStream.Execute then raise EReadError.CreateRes(@SReadError); - DecInput[Index] := TBufferedStream.Create(LStream, True, 4194304); + DecInput[Index] := TCacheStream.Create(LStream, CacheSize); end + else if Depth = 0 then + DecInput[Index] := TCacheStream.Create(Input, CacheSize) else DecInput[Index] := Input; DecOutput[Index] := Output; + LoadResources; DecInput[Index].ReadBuffer(StreamCount[Index]^, StreamCount[Index]^.Size); while StreamCount[Index]^ >= 0 do begin - if (Depth = 0) and (Length(Tasks) > 1) then - if IsErrored(Tasks) then - for I := Low(Tasks) to High(Tasks) do - Tasks[I].RaiseLastError; + if IsErrored(Tasks) then + for I := Low(Tasks) to High(Tasks) do + Tasks[I].RaiseLastError; + DecInput[Index].ReadBuffer(BlockSize, BlockSize.Size); if StreamCount[Index]^ > 0 then begin - DecInput[Index].ReadBuffer(BlockSize, BlockSize.Size); MemStream1[Index].Position := 0; CopyStreamEx(DecInput[Index], MemStream1[Index], StreamCount[Index]^ * SizeOf(TStreamHeader)); CurrPos := 0; - if (Depth = 0) and (Length(Tasks) > 1) and (StreamCount[Index]^ > 1) - then + if ((Depth > 0) and (Length(Tasks) > 1)) or + ((Length(Tasks) > 1) and (StreamCount[Index]^ > 1)) then begin - BlockPos := 0; + BlockPos[Index]^ := 0; StreamInfo[Index]^.SetCount(StreamCount[Index]^); for J := 0 to StreamCount[Index]^ - 1 do begin @@ -2150,8 +2462,8 @@ begin Inc(CurrPos, Max(StreamHeader^.OldSize, StreamHeader^.NewSize)); end; end; - if (Depth = 0) and (Length(Tasks) > 1) and (StreamCount[Index]^ > 1) - then + if ((Depth > 0) and (Length(Tasks) > 1)) or + ((Length(Tasks) > 1) and (StreamCount[Index]^ > 1)) then begin if MemInput[Index].Size < CurrPos then MemInput[Index].Size := CurrPos; @@ -2163,14 +2475,16 @@ begin end; MemInput[Index].Position := 0; StreamIdx[Index]^ := -1; - if (Depth = 0) and (Length(Tasks) > 1) and (StreamCount[Index]^ > 1) - then + if ((Depth > 0) and (Length(Tasks) > 1)) or + ((Length(Tasks) > 1) and (StreamCount[Index]^ > 1)) then begin - for I := Low(Tasks) to High(Tasks) do - begin - Tasks[I].Perform(DecThread); - Tasks[I].Start; - end; + if Depth = 0 then + for I := Low(Tasks) to High(Tasks) do + begin + Tasks[I].Update(I, I, Depth); + Tasks[I].Perform(DecThread); + Tasks[I].Start; + end; for J := 0 to StreamCount[Index]^ - 1 do begin StreamHeader := PStreamHeader(MemStream1[Index].Memory) + J; @@ -2178,16 +2492,19 @@ begin if CopyStream(DecInput[Index], MemInput[Index], StreamHeader^.NewSize) <> StreamHeader^.NewSize then begin - BlockPos := -1; + BlockPos[Index]^ := -1; raise EReadError.CreateRes(@SReadError); end; - Inc(BlockPos, Max(StreamHeader^.OldSize, StreamHeader^.NewSize)); + Inc(BlockPos[Index]^, Max(StreamHeader^.OldSize, + StreamHeader^.NewSize)); end; + if Depth > 0 then + DecThread(Index, Index, Depth); end else CopyStreamEx(DecInput[Index], MemInput[Index], BlockSize); - if (Depth = 0) and (Length(Tasks) > 1) and (StreamCount[Index]^ > 1) - then + if ((Depth > 0) and (Length(Tasks) > 1)) or + ((Length(Tasks) > 1) and (StreamCount[Index]^ > 1)) then begin for J := 0 to StreamCount[Index]^ - 1 do begin @@ -2207,6 +2524,7 @@ begin if ((DDIndex2 < DDCount2) and (DDIndex1 = DDList2[DDIndex2].Index)) then begin + NStream.Update(0, NStream.MaxSize(0) + CalcSysMem); DataMgr.Add(DDIndex1, StreamHeader^.OldSize, DDList2[DDIndex2].Count); DataMgr.Write(DDIndex1, @@ -2222,25 +2540,28 @@ begin ((PByte(MemInput[Index].Memory) + StreamInfo[Index]^.Pos[J])^, StreamHeader^.OldSize); end; - WaitForAll(Tasks); + if Depth = 0 then + WaitForAll(Tasks); end else - Restore(False, Index, Depth); + Restore(False, Index, 0, Depth); end; DecInput[Index].ReadBuffer(UI32, UI32.Size); if UI32 > 0 then CopyStreamEx(DecInput[Index], DecOutput[Index], UI32); + LoadResources; DecInput[Index].ReadBuffer(StreamCount[Index]^, StreamCount[Index]^.Size); end; - if (Depth = 0) and (StoreDD >= 0) then + if (Depth = 0) and (StoreDD > 0) then begin with LStream do begin Wait; Done; end; - DecInput[Index].Free; end; + if Depth = 0 then + DecInput[Index].Free; end; end; @@ -2255,6 +2576,7 @@ var procedure Update; var + I: Integer; TS: TTimeSpan; CreationTime, ExitTime, KernelTime, UserTime: TFileTime; TT: TSystemTime; @@ -2263,17 +2585,40 @@ var GetProcessTimes(GetCurrentProcess, CreationTime, ExitTime, KernelTime, UserTime); FileTimeToSystemTime(TFileTime(Int64(UserTime) + Int64(KernelTime)), TT); - SL[0] := 'Streams: ' + EncInfo.Processed.ToString + '/' + + SL[0] := 'Streams: ' + EncInfo.Processed.ToString + ' / ' + EncInfo.Count.ToString; TS := Stopwatch.Elapsed; SL[1] := 'Time: ' + Format('%0:.2d:%1:.2d:%2:.2d', - [TS.Hours + TS.Days * 24, TS.Minutes, TS.Seconds]) + ' (' + + [TS.Hours + TS.Days * 24, TS.Minutes, TS.Seconds]) + ' (CPU ' + Format('%0:.2d:%1:.2d:%2:.2d', [TT.wHour + Pred(TT.wDay) * 24, TT.wMinute, TT.wSecond]) + ')'; - I64 := InternalMem + EncInfo.DecMem0 + EncInfo.DecMem1; + I64 := EncInfo.DecMem0 + EncInfo.DecMem1; I64 := I64 div 1024; - SL[2] := 'Memory: ' + ConvertKB2TB(I64) + ' (' + - ConvertKB2TB(I64 + EncInfo.DecMem2 div 1024) + ') '; + if StoreDD > -2 then + begin + I := 4; + SL[2] := 'Duplicates: ' + EncInfo.DupCount.ToString + ' (' + + ConvertKB2TB(EncInfo.DecMem2 div 1024) + ') [' + + ConvertKB2TB(EncInfo.DupSize1 div 1024) + ' >> ' + + ConvertKB2TB(EncInfo.DupSize2 div 1024) + '] '; + if StoreDD > 0 then + begin + I := 5; + SL[3] := 'Srep decompression memory: ' + + ConvertKB2TB(EncInfo.SrepMem * 1024) + ' [' + + ConvertKB2TB((EncInfo.SrepMem * 1024) + (EncInfo.DecMem3 div 1024)) + + IfThen(EncInfo.DecMem3 > 0, '*', '') + '] '; + end; + end + else + I := 3; + SL[I] := 'Size: ' + ConvertKB2TB(EncInfo.InSize div 1024) + + IfThen(StoreDD > -2, + ' >> ' + ConvertKB2TB((EncInfo.InflSize + EncInfo.DupSize2) div 1024), '') + + ' >> ' + ConvertKB2TB(EncInfo.InflSize div 1024) + + IfThen(StoreDD > 0, ' >> ' + ConvertKB2TB((EncInfo.SrepSize) div 1024), + '') + IfThen(COMPRESS, ' >> ' + ConvertKB2TB((EncInfo.CompSize) div 1024), + '') + ' '; SetConsoleCursorPosition(FHandle, Coords); WriteConsole(FHandle, PChar(SL.Text), Length(SL.Text), ulLength, nil); end; @@ -2284,9 +2629,16 @@ begin Coords.X := 0; Coords.Y := SBInfo.dwCursorPosition.Y; SL := TStringList.Create; - SL.Add('Streams: 0/0'); + SL.Add('Streams: 0 / 0'); SL.Add('Time: 00:00:00'); - SL.Add('Memory: 0.00 MB (0.00 MB)'); + if StoreDD > -2 then + begin + SL.Add('Duplicates: 0 (0.00 MB) [0.00 MB >> 0.00 MB]'); + if StoreDD > 0 then + SL.Add('Srep decompression memory: 0.00 MB [0.00MB]'); + end; + SL.Add(''); + SL.Add('Size: '); SL.Add(''); while Stopwatch.IsRunning do begin @@ -2317,7 +2669,7 @@ var FileTimeToSystemTime(TFileTime(Int64(UserTime) + Int64(KernelTime)), TT); TS := Stopwatch.Elapsed; SL[0] := 'Time: ' + Format('%0:.2d:%1:.2d:%2:.2d', - [TS.Hours + TS.Days * 24, TS.Minutes, TS.Seconds]) + ' (' + + [TS.Hours + TS.Days * 24, TS.Minutes, TS.Seconds]) + ' (CPU ' + Format('%0:.2d:%1:.2d:%2:.2d', [TT.wHour + Pred(TT.wDay) * 24, TT.wMinute, TT.wSecond]) + ')'; SetConsoleCursorPosition(FHandle, Coords); @@ -2346,7 +2698,7 @@ var Compressed: Boolean; LOutput: TStream; begin - InternalSync.Enter; + NULLOUT := TBufferedStream(Output).Instance is TNullStream; FillChar(EncInfo, SizeOf(EncInfo), 0); ConTask := TTask.Create; Stopwatch := TStopwatch.Create; @@ -2356,16 +2708,27 @@ begin ConTask.Start; try EncInit(Input, Output, @Options); - Compressed := Options.DoCompress; + Compressed := COMPRESS; Output.WriteBuffer(Compressed, Compressed.Size); - if Options.DoCompress then - LOutput := TLZMACompressStream.Create(Output, Options.CompressCfg) + if COMPRESS then + begin + LOutput := TLZMACompressStream.Create(Output); + with LOutput as TLZMACompressStream do + begin + Threads := Options.CThreads; + Dictionary := Options.CDict; + end; + end else LOutput := Output; EncData(Input, LOutput, 0, 0); finally - if Options.DoCompress then + if COMPRESS then + begin + TLZMACompressStream(LOutput).Flush; + EncInfo.CompSize := TLZMACompressStream(LOutput).OutSize; LOutput.Free; + end; try if not EncFreed then EncFree; @@ -2377,7 +2740,6 @@ begin EncodeStats; ConTask.Wait; ConTask.Free; - InternalSync.Leave; end; procedure Decode(Input, Output: TStream; Options: TDecodeOptions); @@ -2385,7 +2747,6 @@ var Compressed: Boolean; LInput: TStream; begin - InternalSync.Enter; FillChar(EncInfo, SizeOf(EncInfo), 0); ConTask := TTask.Create; Stopwatch := TStopwatch.Create; @@ -2398,7 +2759,7 @@ begin DecInit(Input, Output, @Options); Input.ReadBuffer(Compressed, Compressed.Size); if Compressed then - LInput := TLZMADecompressStream.Create(Input, Options.CompressCfg) + LInput := TLZMADecompressStream.Create(Input) else LInput := Input; DecChunk(LInput, Output, 0, 0); @@ -2416,17 +2777,15 @@ begin DecodeStats; ConTask.Wait; ConTask.Free; - InternalSync.Leave; end; initialization -InternalSync := TCriticalSection.Create; PrecompFunctions.GetCodec := @PrecompGetCodec; PrecompFunctions.GetParam := @PrecompGetParam; PrecompFunctions.Allocator := @PrecompAllocator; PrecompFunctions.GetDepthInfo := @PrecompGetDepthInfo; -PrecompFunctions.Compress := @PrecompCompress; +PrecompFunctions.COMPRESS := @PrecompCompress; PrecompFunctions.Decompress := @PrecompDecompress; PrecompFunctions.Encrypt := @PrecompEncrypt; PrecompFunctions.Decrypt := @PrecompDecrypt; @@ -2463,9 +2822,7 @@ PrecompFunctions.LogPatch1 := PrecompLogPatch1; PrecompFunctions.LogPatch2 := PrecompLogPatch2; PrecompFunctions.AcceptPatch := PrecompAcceptPatch; PrecompFunctions.Transfer := PrecompTransfer; - -finalization - -InternalSync.Free; +PrecompFunctions.Storage := PrecompStorage; +PrecompFunctions.AddResourceEx := PrecompAddResourceEx; end. diff --git a/precompressor/PrecompMedia.pas b/precompressor/PrecompMedia.pas index 032de67..89d0670 100644 --- a/precompressor/PrecompMedia.pas +++ b/precompressor/PrecompMedia.pas @@ -25,7 +25,7 @@ const const FLAC_LEVEL = 5; - J_WORKMEM = 262144; + J_WORKMEM = 65536; type PFlacEncCD = ^TFlacEncCD; @@ -776,6 +776,7 @@ begin JOJPEG_CODEC: begin ctx := JJInst[Instance]; + FillChar(ctx^, jojpeg_Size, 0); Buffer := Funcs^.Allocator(Instance, J_WORKMEM * 2); I := 0; J := 0; @@ -789,14 +790,14 @@ begin while True do begin Res1 := jojpeg_Loop(ctx, jojpeg_Compress); - if (Res1 = jojpeg_enc_Input) then + if (Res1 = 1) then begin Res2 := Min(StreamInfo^.OldSize - I, J_WORKMEM); jojpeg_Addbuf(ctx, jojpeg_Compress, PByte(OldInput) + I, Res2, jojpeg_enc_Input); Inc(I, Res2); end; - if (Res1 in [0, jojpeg_enc_Output1]) then + if (Res1 in [0, 2]) then begin Res2 := jojpeg_Getvalue(ctx, jojpeg_Compress, jojpeg_enc_Output1); Move(Buffer^, (PByte(NewInput) + J)^, Res2); @@ -804,7 +805,7 @@ begin jojpeg_Addbuf(ctx, jojpeg_Compress, Buffer, J_WORKMEM, jojpeg_enc_Output1); end; - if (Res1 = jojpeg_enc_Output2) or (Res1 = 0) then + if (Res1 = 3) or (Res1 = 0) then begin Res2 := jojpeg_Getvalue(ctx, jojpeg_Compress, jojpeg_enc_Output2); Output(Instance, Buffer + J_WORKMEM, Res2); @@ -898,6 +899,7 @@ begin JOJPEG_CODEC: begin ctx := JJInst[Instance]; + FillChar(ctx^, jojpeg_Size, 0); Buffer := Funcs^.Allocator(Instance, J_WORKMEM); I := 0; J := 0; diff --git a/precompressor/PrecompOodle.pas b/precompressor/PrecompOodle.pas index 688a0f1..927f437 100644 --- a/precompressor/PrecompOodle.pas +++ b/precompressor/PrecompOodle.pas @@ -26,6 +26,7 @@ const const O_MAXSIZE = 16 * 1024 * 1024; + O_WORKMEM = 64 * 1024 * 1024; O_LENGTH = 32; O_TRADEOFF = 256; O_DICTIONARY = 0; @@ -382,8 +383,8 @@ begin for I := Low(SOList) to High(SOList) do SOList[I][Y].Update ([StrToInt(Funcs^.GetParam(Command, X, 'l'))], True); - if Funcs^.GetParam(Command, X, 'm') <> '' then - OMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + OMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); if Funcs^.GetParam(Command, X, 'n') <> '' then OLength := StrToInt(Funcs^.GetParam(Command, X, 'n')); if Funcs^.GetParam(Command, X, 't') <> '' then @@ -595,9 +596,11 @@ end; function OodleProcess(Instance, Depth: Integer; OldInput, NewInput: Pointer; StreamInfo: PStrInfo2; Output: _PrecompOutput; Funcs: PPrecompFuncs): Boolean; var - Buffer: PByte; + Buffer, Work: PByte; Params: String; + A, B: Integer; I: Integer; + W: Integer; X, Y: Integer; Res1: Integer; Res2: NativeUInt; @@ -609,7 +612,18 @@ begin exit; Y := GetOodleCodec(X); Buffer := Funcs^.Allocator(Instance, OodleLZ_GetCompressedBufferSizeNeeded(Y, - StreamInfo^.NewSize)); + StreamInfo^.NewSize) + IfThen(OldCompress, 0, O_WORKMEM)); + if OldCompress then + begin + Work := nil; + W := 0 + end + else + begin + Work := Buffer + OodleLZ_GetCompressedBufferSizeNeeded(Y, + StreamInfo^.NewSize); + W := O_WORKMEM; + end; SOList[Instance][X].Index := 0; while SOList[Instance][X].Get(I) >= 0 do begin @@ -635,7 +649,7 @@ begin + 'd' + GetBits(StreamInfo^.Option, 24, 5).ToString; if not Result then Res1 := OodleLZ_Compress(Y, NewInput, StreamInfo^.NewSize, Buffer, I, - @COptions); + @COptions, nil, nil, Work, W); if not Result then Result := (Res1 = StreamInfo^.OldSize) and CompareMem(OldInput, Buffer, StreamInfo^.OldSize); @@ -644,6 +658,27 @@ begin if Result or (StreamInfo^.Status = TStreamStatus.Predicted) then break; end; + if Result and OPTIMISE_DEC and (StreamInfo^.Status <> TStreamStatus.Database) + then + begin + A := Pred(I); + for B := A downto 1 do + begin + Move(OodleLZ_CompressOptions_GetDefault(Y, B)^, COptions, + SizeOf(TOodleLZ_CompressOptions)); + COptions.sendQuantumCRCs := GetBits(StreamInfo^.Option, 12, 1) = 1; + COptions.spaceSpeedTradeoffBytes := GetBits(StreamInfo^.Option, 13, 11); + COptions.dictionarySize := IfThen(GetBits(StreamInfo^.Option, 24, 5) = 0, + 0, Round(Power(2, GetBits(StreamInfo^.Option, 24, 5)))); + Res1 := OodleLZ_Compress(Y, NewInput, StreamInfo^.NewSize, Buffer, B, + @COptions, nil, nil, Work, W); + if (Res1 = StreamInfo^.OldSize) and CompareMem(OldInput, Buffer, + StreamInfo^.OldSize) then + I := B + else + break; + end; + end; { if (Result = False) and ((StreamInfo^.Status >= TStreamStatus.Predicted) or (SOList[Instance][X].Count = 1)) and (DIFF_TOLERANCE > 0) then begin @@ -670,8 +705,9 @@ end; function OodleRestore(Instance, Depth: Integer; Input, InputExt: Pointer; StreamInfo: _StrInfo3; Output: _PrecompOutput; Funcs: PPrecompFuncs): Boolean; var - Buffer: PByte; + Buffer, Work: PByte; Params: String; + W: Integer; X, Y: Integer; Res1: Integer; Res2: NativeUInt; @@ -683,7 +719,18 @@ begin exit; Y := GetOodleCodec(X); Buffer := Funcs^.Allocator(Instance, OodleLZ_GetCompressedBufferSizeNeeded(Y, - StreamInfo.NewSize)); + StreamInfo.NewSize) + IfThen(OldCompress, 0, O_WORKMEM)); + if OldCompress then + begin + Work := nil; + W := 0 + end + else + begin + Work := Buffer + OodleLZ_GetCompressedBufferSizeNeeded(Y, + StreamInfo.NewSize); + W := O_WORKMEM; + end; Move(OodleLZ_CompressOptions_GetDefault(Y, GetBits(StreamInfo.Option, 5, 7))^, COptions, SizeOf(TOodleLZ_CompressOptions)); COptions.sendQuantumCRCs := GetBits(StreamInfo.Option, 12, 1) = 1; @@ -695,7 +742,7 @@ begin GetBits(StreamInfo.Option, 13, 11).ToString + ':' + 'd' + GetBits(StreamInfo.Option, 24, 5).ToString; Res1 := OodleLZ_Compress(Y, Input, StreamInfo.NewSize, Buffer, - GetBits(StreamInfo.Option, 5, 7), @COptions); + GetBits(StreamInfo.Option, 5, 7), @COptions, nil, nil, Work, W); Funcs^.LogRestore(OodleCodecs[GetBits(StreamInfo.Option, 0, 5)], PChar(Params), StreamInfo.OldSize, StreamInfo.NewSize, Res1, True); if GetBits(StreamInfo.Option, 31, 1) = 1 then diff --git a/precompressor/PrecompSearch.pas b/precompressor/PrecompSearch.pas index a53ddb9..6ed090e 100644 --- a/precompressor/PrecompSearch.pas +++ b/precompressor/PrecompSearch.pas @@ -77,7 +77,7 @@ begin while Y > 0 do begin Inc(LPos, Y); - CRC := Utils.Hash32(CRC, @Buffer[0], Y); + CRC := Utils.CRC32(CRC, @Buffer[0], Y); Dec(X, Y); Y := Funcs^.ReadFuture(Instance, LPos, @Buffer[0], Min(X, BufferSize)); end; @@ -201,7 +201,7 @@ begin begin if not Checked then begin - CRC := Utils.Hash32(0, Input + Pos, MinSize); + CRC := Utils.CRC32(0, Input + Pos, MinSize); Checked := True; end; if (CodecSearch[I, SearchInfo[I, J, X]].Hash = CRC) and diff --git a/precompressor/PrecompUtils.pas b/precompressor/PrecompUtils.pas index d1eb443..645e5e7 100644 --- a/precompressor/PrecompUtils.pas +++ b/precompressor/PrecompUtils.pas @@ -3,7 +3,8 @@ unit PrecompUtils; interface uses - Utils, Threading, + InitCode, + Utils, Threading, XXHASHLIB, WinAPI.Windows, System.SysUtils, System.Classes, System.StrUtils, System.Types, System.Math, System.Generics.Defaults, System.Generics.Collections; @@ -55,7 +56,7 @@ type Codec: Byte; Scan2: Boolean; Option: Integer; - Checksum: Cardinal; + Checksum: XXH128_hash_t; Status: TStreamStatus; DepthInfo: TDepthInfo; end; @@ -194,7 +195,9 @@ type AcceptPatch: function(OldSize, NewSize, PatchSize: Integer): Boolean cdecl; // 40 Transfer: procedure(Instance: Integer; Codec: PChar)cdecl; - Reserved: array [0 .. (PRECOMP_FCOUNT - 1) - 41] of Pointer; + Storage: function(Instance: Integer; Size: PInteger): Pointer cdecl; + AddResourceEx: function(Data: Pointer; Size: Integer): Integer cdecl; + Reserved: array [0 .. (PRECOMP_FCOUNT - 1) - 43] of Pointer; end; _PrecompOutput = procedure(Instance: Integer; const Buffer: Pointer; @@ -248,7 +251,7 @@ type Size: Integer; Codec: Byte; Option: Integer; - Checksum: Cardinal; + Checksum: XXH128_hash_t; Status: TStreamStatus; end; @@ -256,7 +259,7 @@ type TDuplicate1 = packed record Size: Integer; - Checksum: Cardinal; + Checksum: XXH128_hash_t; Index: Integer; Count: Integer; end; @@ -366,6 +369,7 @@ function PrecompAcceptPatch(OldSize, NewSize, PatchSize: Integer) var PrecompFunctions: _PrecompFuncs; DIFF_TOLERANCE: Single = 0.05; + OPTIMISE_DEC: Boolean = False; EncodeSICmp: TEncodeSIComparer; FutureSICmp: TFutureSIComparer; StockMethods, ExternalMethods: TStringList; @@ -427,10 +431,9 @@ begin List2 := DecodeStr(List1[I], SPrecompSep2); for J := Succ(Low(List2)) to High(List2) do begin - if FileExists(ExtractFilePath(Utils.GetModuleName) + List2[J]) then + if FileExists(PluginsPath + List2[J]) then begin - Result := PrecompAddResource - (PChar(ExtractFilePath(Utils.GetModuleName) + List2[J])); + Result := PrecompAddResource(PChar(List2[J])); break; end; end; @@ -591,7 +594,7 @@ begin else begin for I := Succ(Low(List2)) to High(List2) do - if List2[I].StartsWith(Param, True) and + if List2[I].StartsWith(Param, False) and (ResourceExists(List2[I]) = False) then begin S := List2[I].Substring(Length(Param)); @@ -649,14 +652,14 @@ begin if S = '' then S := '15'; FillChar(ZStream, SizeOf(z_stream), 0); + ZStream.next_in := InBuff; + ZStream.avail_in := InSize; + ZStream.next_out := OutBuff; + ZStream.avail_out := OutSize; deflateInit2(ZStream, I div 10, Z_DEFLATED, -StrToInt(S), I mod 10, Z_DEFAULT_STRATEGY); try - ZStream.next_in := InBuff; - ZStream.avail_in := InSize; - ZStream.next_out := OutBuff; - ZStream.avail_out := OutSize; - if deflate(ZStream, Z_FULL_FLUSH) = Z_STREAM_END then + if deflate(ZStream, Z_FINISH) = Z_STREAM_END then Result := ZStream.total_out; finally deflateEnd(ZStream); @@ -733,7 +736,7 @@ begin ZStream.avail_in := InSize; ZStream.next_out := OutBuff; ZStream.avail_out := OutSize; - if inflate(ZStream, Z_FULL_FLUSH) = Z_STREAM_END then + if inflate(ZStream, Z_FINISH) = Z_STREAM_END then Result := ZStream.total_out; finally inflateEnd(ZStream); @@ -825,9 +828,12 @@ var LMD5Digest: TMD5Digest; LSHA1: TSHA1; LSHA1Digest: TSHA1Digest; + xxSeed32: XXH32_hash_t; + xxSeed64: XXH32_hash_t; begin Result := False; - case IndexText(Codec, ['crc32', 'adler32', 'crc64', 'md5', 'sha1']) of + case IndexText(Codec, ['crc32', 'adler32', 'crc64', 'md5', 'sha1', 'xxh32', + 'xxh64', 'xxh128', 'xxh3', 'xxh3_128']) of 0: if HashSize = SizeOf(Cardinal) then begin @@ -861,6 +867,39 @@ begin Move(LSHA1Digest, HashBuff^, HashSize); Result := True; end; + 5: + if HashSize = SizeOf(XXH32_hash_t) then + begin + xxSeed32 := 0; + PXXH32_hash_t(HashBuff)^ := XXH32(InBuff, InSize, xxSeed32); + Result := True; + end; + 6: + if HashSize = SizeOf(XXH64_hash_t) then + begin + xxSeed64 := 0; + PXXH64_hash_t(HashBuff)^ := XXH64(InBuff, InSize, xxSeed64); + Result := True; + end; + 7: + if HashSize = SizeOf(XXH128_hash_t) then + begin + xxSeed64 := 0; + PXXH128_hash_t(HashBuff)^ := XXH128(InBuff, InSize, xxSeed64); + Result := True; + end; + 8: + if HashSize = SizeOf(XXH64_hash_t) then + begin + PXXH64_hash_t(HashBuff)^ := XXH3_64bits(InBuff, InSize); + Result := True; + end; + 9: + if HashSize = SizeOf(XXH128_hash_t) then + begin + PXXH128_hash_t(HashBuff)^ := XXH3_128bits(InBuff, InSize); + Result := True; + end; end; end; @@ -898,7 +937,6 @@ function PrecompAddResource(FileName: PChar): Integer; var I: Integer; Exists: Boolean; - LResData: PResData; begin Result := -1; Exists := False; @@ -913,18 +951,19 @@ begin end; if not Exists then begin - New(LResData); - LResData^.Name := ExtractFileName(FileName); - with TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone) do + with TFileStream.Create(PluginsPath + FileName, fmOpenRead or + fmShareDenyNone) do try - LResData^.Size := Size; - GetMem(LResData^.Data, LResData^.Size); - ReadBuffer(LResData^.Data^, LResData^.Size); + I := Length(Resources); + SetLength(Resources, Succ(I)); + Resources[I].Name := ExtractFileName(FileName); + Resources[I].Size := Size; + GetMem(Resources[I].Data, Resources[I].Size); + ReadBuffer(Resources[I].Data^, Resources[I].Size); + Result := I; finally Free; end; - Insert(LResData^, Resources, Length(Resources)); - Result := Pred(Length(Resources)); end; end; diff --git a/precompressor/PrecompZLib.pas b/precompressor/PrecompZLib.pas index 2e95e72..4c13636 100644 --- a/precompressor/PrecompZLib.pas +++ b/precompressor/PrecompZLib.pas @@ -483,9 +483,10 @@ begin Inc(Pos); continue; end; - if (Pos >= 2) and ((Input + Pos - 2)^ and $F = 8) and + if (Pos >= 3) and ((Input + Pos - 2)^ and $F = 8) and ((Input + Pos - 1)^ and $20 = 0) and - (EndianSwap(PWord(Input + Pos - 2)^) mod $1F = 0) then + (EndianSwap(PWord(Input + Pos - 2)^) mod $1F = 0) and + ((Input + Pos)^ and 7 <> $7) then begin WinBits := (Input + Pos - 2)^ shr 4; if WinBits = ZWinBits then @@ -565,6 +566,8 @@ begin else SI.Status := TStreamStatus.None; SetBits(SI.Option, WinBits, 12, 3); + if not((Input + Pos)^ and 7 in [$4, $5]) then + SetBits(SI.Option, 1, 15, 1); for I := Low(CodecEnabled) to High(CodecEnabled) do begin if (I = ZLIB_CODEC) and (WinBits = 0) then @@ -761,6 +764,7 @@ begin if (Res1 in [0, 2]) or (Res1 > 3) then begin Res2 := raw2hif_getoutlen(HR); + // ShowMessage('enc: ' + Res2.ToString); Output(Instance, Buffer, Res2); Inc(J, Res2); raw2hif_addbuf(HR, Buffer, R_WORKMEM); @@ -785,8 +789,49 @@ begin StreamInfo^.OldSize, M = StreamInfo^.NewSize); if M = StreamInfo^.NewSize then begin - SetBits(StreamInfo^.Option, L, 5, 7); - Result := True; + if GetBits(StreamInfo^.Option, 15, 1) = 1 then + begin + HR := RefInst2[Instance]; + I := 0; + J := 0; + M := 0; + CRC := 0; + Ptr := Funcs^.Storage(Instance, @M); + // ShowMessage('dec: ' + M.ToString); + hif2raw_Init(HR, L); + while True do + begin + Res1 := hif2raw_Loop(HR); + if (Res1 in [0, 2]) or (Res1 > 3) then + begin + Res2 := hif2raw_getoutlen(HR); + if Res2 > 0 then + CRC := Hash32(CRC, Buffer, Res2); + hif2raw_addbuf(HR, Buffer, R_WORKMEM); + if Res1 = 0 then + break; + end; + if Res1 = 1 then + begin + Res2 := Min(M - J, R_WORKMEM); + hif2raw_addbuf(HR, Ptr + J, Res2); + Inc(J, Res2); + end; + if Res1 = 3 then + begin + Res2 := Min(StreamInfo^.NewSize - I, R_WORKMEM); + hif2raw_addbuf(HR, PByte(NewInput) + I, Res2); + Inc(I, Res2); + end; + end; + end; + if (GetBits(StreamInfo^.Option, 15, 1) = 0) or + (CRC = Hash32(0, OldInput, StreamInfo^.OldSize)) then + begin + // ShowMessage('Verified!'); + SetBits(StreamInfo^.Option, L, 5, 7); + Result := True; + end; end; end; PREFLATE_CODEC: diff --git a/precompressor/PrecompZSTD.pas b/precompressor/PrecompZSTD.pas index 327b4e3..0daba43 100644 --- a/precompressor/PrecompZSTD.pas +++ b/precompressor/PrecompZSTD.pas @@ -60,8 +60,8 @@ begin for I := Low(SOList) to High(SOList) do SOList[I][ZSTD_CODEC].Update ([StrToInt(Funcs^.GetParam(Command, X, 'l'))], True); - if Funcs^.GetParam(Command, X, 'm') <> '' then - ZMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 'm')); + if Funcs^.GetParam(Command, X, 's') <> '' then + ZMaxSize := ConvertToBytes(Funcs^.GetParam(Command, X, 's')); end; Inc(X); end; @@ -249,6 +249,7 @@ function ZSTDProcess(Instance, Depth: Integer; OldInput, NewInput: Pointer; var Buffer: PByte; Params: String; + A, B: Integer; I: Integer; X: Integer; Res1: Integer; @@ -323,8 +324,23 @@ begin if Result or (StreamInfo^.Status >= TStreamStatus.Predicted) then break; end; - if (Result = False) and ((StreamInfo^.Status >= TStreamStatus.Predicted) or - (SOList[Instance][X].Count = 1)) and (DIFF_TOLERANCE > 0) then + if Result and OPTIMISE_DEC and (StreamInfo^.Status <> TStreamStatus.Database) + then + begin + A := Pred(I); + for B := A downto 1 do + begin + Res1 := ZSTD_compressCCtx(cctx[Instance], Buffer, StreamInfo^.NewSize, + NewInput, StreamInfo^.NewSize, B); + if (Res1 = StreamInfo^.OldSize) and CompareMem(OldInput, Buffer, + StreamInfo^.OldSize) then + I := B + else + break; + end; + end + else if (Result = False) and ((StreamInfo^.Status >= TStreamStatus.Predicted) + or (SOList[Instance][X].Count = 1)) and (DIFF_TOLERANCE > 0) then begin Buffer := Funcs^.Allocator(Instance, Res1 + Max(StreamInfo^.OldSize, Res1)); Res2 := PrecompEncodePatch(OldInput, StreamInfo^.OldSize, Buffer, Res1, diff --git a/xtool.dpr b/xtool.dpr index 9828a55..f62e9d2 100644 --- a/xtool.dpr +++ b/xtool.dpr @@ -1,6 +1,6 @@ { MIT License - Copyright (c) 2016-2022 Razor12911 + Copyright (c) 2016-2023 Razor12911 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal @@ -26,8 +26,14 @@ program xtool; {$R *.res} {$WEAKLINKRTTI ON} {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} +{$POINTERMATH ON} +{$DEFINE UseFastMM} uses +{$IFDEF UseFastMM} + FastMM4 in 'contrib\FastMM4-AVX\FastMM4.pas', + FastMM4Messages in 'contrib\FastMM4-AVX\FastMM4Messages.pas', +{$ENDIF } WinAPI.Windows, System.SysUtils, System.StrUtils, @@ -35,6 +41,7 @@ uses System.Types, System.Math, System.IOUtils, + System.SyncObjs, LibImport in 'common\LibImport.pas', Threading in 'common\Threading.pas', Utils in 'common\Utils.pas', @@ -48,6 +55,7 @@ uses oObjects in 'contrib\ParseExpression\oObjects.pas', ParseClass in 'contrib\ParseExpression\ParseClass.pas', ParseExpr in 'contrib\ParseExpression\ParseExpr.pas', + XXHASHLIB in 'contrib\XXHASH4Delphi\XXHASHLIB.pas', InitCode in 'InitCode.pas', BrunsliDLL in 'imports\BrunsliDLL.pas', FLACDLL in 'imports\FLACDLL.pas', @@ -265,15 +273,8 @@ begin for I := 1 to High(ParamStr_) do S := S + IfThen(ParamStr_[I].Contains(' '), '"' + ParamStr_[I] + '"', ParamStr_[I]) + ' '; - PrecompMain.Parse(ParamStr_, PrecompEnc); if LibType = 0 then - begin - WriteLine('Chunk size: ' + ConvertKB2TB(PrecompEnc.ChunkSize div 1024) + - ', ' + 'Threads: ' + PrecompEnc.Threads.ToString + ', ' + 'Depth: ' + - (PrecompEnc.Depth - 1).ToString); - WriteLine(''); - Exec_(ParamStr(0), S, ''); - end + Exec_(ParamStr(0), S, '') else begin LibList := TDirectory.GetFiles(LibPath, '*.dll', @@ -288,11 +289,11 @@ begin if I = 1 then case LibType of 1: - S := S + '"' + '-l4' + LibList[J] + '"' + ' '; + S := S + '"' + '-lz4' + LibList[J] + '"' + ' '; 2: - S := S + '"' + '-zs' + LibList[J] + '"' + ' '; + S := S + '"' + '-zstd' + LibList[J] + '"' + ' '; 3: - S := S + '"' + '-od' + LibList[J] + '"' + ' '; + S := S + '"' + '-oodle' + LibList[J] + '"' + ' '; end; end; WriteLine('Library loaded: ' + ReplaceText(LibList[J], @@ -301,6 +302,8 @@ begin Exec_(ParamStr(0), S, ''); end; end; + WriteLine('Done!!!'); + WriteLine(''); end; exit; end; @@ -336,12 +339,6 @@ begin try PrecompMain.Parse(ParamArg[0], PrecompEnc); PrecompMain.Encode(Input, Output, PrecompEnc); - if TBufferedStream(Output).Instance is TNullStream then - begin - WriteLine('Results: ' + ConvertKB2TB(Input.Size div 1024) + ' >> ' + - ConvertKB2TB(Output.Size div 1024)); - WriteLine(''); - end; finally Input.Free; Output.Free; @@ -423,7 +420,7 @@ begin IOArchive.PrintHelp else begin - SetLength(StrArray, 0); + setlength(StrArray, 0); for I := 0 to High(ParamArg[1]) - 1 do Insert(ParamArg[1, I], StrArray, Length(StrArray)); Output := TBufferedStream.Create @@ -440,7 +437,7 @@ begin IOExecute.PrintHelp else begin - SetLength(StrArray, 0); + setlength(StrArray, 0); for I := 2 to High(ParamArg[1]) do Insert(ParamArg[1, I], StrArray, Length(StrArray)); Input := TBufferedStream.Create(GetInStream(ParamArg[1, 0]), True, @@ -505,7 +502,7 @@ begin end; XTOOL_EXEC: begin - SetLength(StrArray, 0); + setlength(StrArray, 0); for I := 2 to High(ParamArg[1]) do Insert(ParamArg[1, I], StrArray, Length(StrArray)); Output := TBufferedStream.Create(GetOutStream(ParamArgSafe(1, 1) @@ -526,6 +523,8 @@ begin on E: Exception do begin WriteLine(E.ClassName + ': ' + E.Message); + if DEBUG then + ShowMessage(E.ClassName + ': ' + E.Message); ExitCode := 1; end; end; diff --git a/xtool.dproj b/xtool.dproj index fed78e5..cd2b122 100644 --- a/xtool.dproj +++ b/xtool.dproj @@ -152,6 +152,8 @@ MainSource + + @@ -165,6 +167,7 @@ + @@ -206,6 +209,7 @@ + Base @@ -245,12 +249,30 @@ + + .\ + true + + + + + .\ + true + + + .\ true + + + xtool.exe + true + + diff --git a/xtool.res b/xtool.res index 171aa0e..d6ea49a 100644 Binary files a/xtool.res and b/xtool.res differ diff --git a/xtoolui.dpr b/xtoolui.dpr index add3de0..13add78 100644 --- a/xtoolui.dpr +++ b/xtoolui.dpr @@ -1,5 +1,7 @@ library xtoolui; +{$WEAKLINKRTTI ON} +{$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} {$R *.res} uses @@ -8,6 +10,7 @@ uses FMX.Types, FMX.Controls, FMX.StdCtrls, + FMX.TabControl, WinAPI.Windows, System.SysUtils, System.Types, @@ -20,6 +23,7 @@ const PLUGIN_DATABASE = 0; PLUGIN_CONFIG = 1; PLUGIN_LIBRARY = 2; + PLUGIN_EXECUTABLE = 3; type PUIFuncs = ^TUIFuncs; @@ -61,7 +65,9 @@ begin UIInitialised := True; Form1.Edit6.Text := GetIniString('UI', 'Plugins', '', ChangeFileExt(GetModuleName, '.ini')); + Form1.Edit28.Text := Form1.Edit6.Text; Form1.Edit6.OnChange := Form1.Edit6Change; + Form1.Edit28.OnChange := Form1.Edit6Change; { Form2.CheckBox3.Enabled := Funcs^.IsZlibLoaded; Form2.CheckBox1.Enabled := Funcs^.IsReflateLoaded; Form2.CheckBox2.Enabled := Funcs^.IsPreflateLoaded; @@ -83,7 +89,8 @@ begin Form2.RadioButton2.Enabled := Funcs^.IsPackJPGLoaded; Form2.RadioButton3.Enabled := Funcs^.IsJoJpegLoaded; Form1.GroupBox5.Enabled := Funcs^.IsLZMALoaded; } - Form1.SpinBox4.Enabled := Funcs^.IsSrepAvailable; + if not Funcs^.IsSrepAvailable then + Form1.ComboBox5.Items.Delete(2); for I := Low(Methods) to High(Methods) do begin case Methods[I].FType of @@ -110,10 +117,11 @@ begin end; end; for I := 0 to Form2.ComponentCount - 1 do - begin if Form2.Components[I] is TExpander then TExpander(Form2.Components[I]).IsExpanded := False; - end; + for I := 0 to Form1.ComponentCount - 1 do + if Form1.Components[I] is TTabControl then + TTabControl(Form1.Components[I]).TabIndex := 0; if Form2.ListBox2.Items.Count = 0 then Form2.Expander10.Visible := False; end; @@ -150,5 +158,6 @@ end; exports XTLUI1, XTLUI2, XTLAddPlugin, XTLAddCodec; begin + FormatSettings := TFormatSettings.Invariant; end. diff --git a/xtoolui.res b/xtoolui.res index 0cb0c10..4075f38 100644 Binary files a/xtoolui.res and b/xtoolui.res differ