diff --git a/Demo/DelphiASTDemo.dproj b/Demo/DelphiASTDemo.dproj index 978aa9a0..ed8331b8 100644 --- a/Demo/DelphiASTDemo.dproj +++ b/Demo/DelphiASTDemo.dproj @@ -1,7 +1,7 @@  {6DAA4B8F-6103-4418-BAA9-E92227FE34C9} - 18.1 + 18.5 VCL DelphiASTDemo.dpr True @@ -54,6 +54,8 @@ true IndyIPClient;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;FireDACDSDriver;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;RESTBackendComponents;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;tethering;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapServer;DataSnapCommon;DBXOdbcDriver;vclFireDAC;DataSnapProviderClient;xmlrtl;DataSnapNativeClient;DBXSybaseASEDriver;DbxCommonDriver;svnui;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindcompdbx;bindengine;vclactnband;vcldb;soaprtl;vcldsnap;bindcompvcl;vclie;fmxFireDAC;FireDACADSDriver;DBXDb2Driver;vcltouch;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;DBXInformixDriver;fmxase;vcl;IndyCore;IndyIPServer;DataSnapServerMidas;DBXMSSQLDriver;IndyIPCommon;VCLRESTComponents;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;CloudService;DataSnapFireDAC;fmxobj;DataSnapConnectors;FireDACDBXDriver;FireDACMySQLDriver;soapmidas;vclx;soapserver;inetdbxpress;CodeSiteExpressPkg;svn;DBXSybaseASADriver;dsnapxml;FireDACOracleDriver;FireDACInfxDriver;FireDACDb2Driver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;dbexpress;DataSnapIndy10ServerTransport;adortl;$(DCC_UsePackage) 1033 + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png DEBUG;$(DCC_Define) @@ -67,6 +69,9 @@ true 1033 false + Debug + W:\projects\Components\FastMM4;$(DCC_UnitSearchPath) + true false @@ -82,6 +87,7 @@
MainForm
dfm + Cfg_2 Base @@ -103,395 +109,14 @@ DelphiASTDemo.dpr - Microsoft Office 2000 Sample Automation Server Wrapper Components - Microsoft Office XP Sample Automation Server Wrapper Components + DBExpress Enterprise Data Explorer Integration + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + Embarcadero C++Builder Office 2000 Servers Package + Embarcadero C++Builder Office XP Servers Package - - - - 1 - .dylib - - - 0 - .bpl - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - 1 - .dylib - - - 0 - .dll;.bpl - - - Contents\MacOS - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - - - 1 - - - 1 - - - 1 - - - - - Contents - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - res\drawable-normal - 1 - - - - - library\lib\x86 - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ../ - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-xlarge - 1 - - - - - res\drawable-xhdpi - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-xxhdpi - 1 - - - - - library\lib\mips - 1 - - - - - res\drawable - 1 - - - - - Contents\MacOS - 1 - - - 1 - - - 0 - - - - - Contents\MacOS - 1 - .framework - - - 0 - - - - - res\drawable-small - 1 - - - - - ../ - 1 - - - ../ - 1 - - - - - Contents\MacOS - 1 - - - 1 - - - Contents\MacOS - 0 - - - - - classes - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable - 1 - - - - - Contents\Resources - 1 - - - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi-v7a - 1 - - - 1 - - - 0 - - - Contents\MacOS - 1 - - - 1 - - - 1 - - - - - library\lib\armeabi - 1 - - - - - res\drawable-large - 1 - - - - - 0 - - - 0 - - - 0 - - - Contents\MacOS - 0 - - - 0 - - - 0 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-ldpi - 1 - - - - - res\values - 1 - - - - - 1 - - - 1 - - - 1 - - - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - - - 1 - - - - - - - - - - + True diff --git a/Demo/DelphiASTDemo.res b/Demo/DelphiASTDemo.res index 49961f02..aff75aeb 100644 Binary files a/Demo/DelphiASTDemo.res and b/Demo/DelphiASTDemo.res differ diff --git a/Demo/uMainForm.dfm b/Demo/uMainForm.dfm index 74f85108..8bb70a41 100644 --- a/Demo/uMainForm.dfm +++ b/Demo/uMainForm.dfm @@ -33,7 +33,7 @@ object MainForm: TMainForm Width = 50 end> end - object CheckBox1: TCheckBox + object chkStringIntern: TCheckBox AlignWithMargins = True Left = 3 Top = 350 diff --git a/Demo/uMainForm.pas b/Demo/uMainForm.pas index 357c4dfc..92f12ba8 100644 --- a/Demo/uMainForm.pas +++ b/Demo/uMainForm.pas @@ -14,8 +14,8 @@ TMainForm = class(TForm) MainMenu: TMainMenu; OpenDelphiUnit1: TMenuItem; OpenDialog: TOpenDialog; - StatusBar: TStatusBar; - CheckBox1: TCheckBox; + StatusBar: TStatusBar; + chkStringIntern: TCheckBox; procedure OpenDelphiUnit1Click(Sender: TObject); private procedure UpdateStatusBarText(const StatusText: string); @@ -121,7 +121,7 @@ procedure TMainForm.OpenDelphiUnit1Click(Sender: TObject); begin if OpenDialog.Execute then begin - OutputMemo.Lines.Text := Parse(OpenDialog.FileName, StatusText, CheckBox1.Checked); + OutputMemo.Lines.Text := Parse(OpenDialog.FileName, StatusText, chkStringIntern.Checked); UpdateStatusBarText(StatusText); end end; diff --git a/README.md b/README.md index 93b96b6c..4869899c 100644 --- a/README.md +++ b/README.md @@ -1,89 +1,23 @@ -### Abstract Syntax Tree Builder for Delphi -With DelphiAST you can take real Delphi code and get an abstract syntax tree. One unit at time and without a symbol table though. +### Abstract Syntax Tree Builder for Delphi +With DelphiAST you can take real Delphi code and get an abstract syntax tree. -FreePascal and Lazarus compatible. +### This fork -#### Sample input -```delphi -unit Unit1; - -interface - -uses - Unit2; - -function Sum(A, B: Integer): Integer; +This is a fork of https://github.com/RomanYankovsky/DelphiAST which adds: -implementation +* Nodes are not repeatedly allocated and freed, instead using an object cache when a new one is created or destroyed (see `TSyntaxNode` in DelphiAST.Classes.pas. The interesting bit is: -function Sum(A, B: Integer): Integer; -begin - Result := A + B; -end; - -end. +```delphi + class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override; + procedure FreeInstance; override; ``` -#### Sample outcome -```xml - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -``` +* String interning, using a different technique to the one currently in DelphiAST (written afterwards? The code in this fork dates from 2016.) This is disabled by default currently since the latest DelphiAST has its own technique. + +The general idea is to try to prevent memory fragmentation or many allocations and de-allocations when DelphiAST is used constantly. This code is used in the [Parnassus Bookmarks and Navigator plugins](https://parnassus.co/delphi-tools/), which regularly parse the current unit when the user types. That can be many times an hour, even many times a minute. Early versions had users reporting the IDE gave out of memory errors where there was still a lot of free memory, a classic indication of fragmentation. Releases using this code, especially the string interning, solved those bug reports. #### Copyright -Copyright (c) 2014-2017 Roman Yankovsky (roman@yankovsky.me) et al +Copyright (c) 2014-2017 Roman Yankovsky (roman@yankovsky.me) et al (these changes are copyright David Millington 2016-2018.) DelphiAST is released under the Mozilla Public License, v. 2.0 diff --git a/Source/DelphiAST.Classes.pas b/Source/DelphiAST.Classes.pas index 183c8eb9..45aa6329 100644 --- a/Source/DelphiAST.Classes.pas +++ b/Source/DelphiAST.Classes.pas @@ -2,10 +2,16 @@ {$IFDEF FPC}{$MODE DELPHI}{$ENDIF} +// Define this to use a memory pool for node instances +{$define USEBULKALLOCATOR} + interface uses - SysUtils, Generics.Collections, SimpleParser.Lexer.Types, DelphiAST.Consts; + SysUtils, Generics.Collections, SimpleParser.Lexer.Types, DelphiAST.Consts + {$ifdef USESTRINGCACHE}, SimpleParser.StringCache{$endif} + {$ifdef USEBULKALLOCATOR}, SimpleParser.ObjectAllocator{$endif} + ; type EParserException = class(Exception) @@ -19,12 +25,27 @@ EParserException = class(Exception) property Line: Integer read FLine; property Col: Integer read FCol; end; + + {$ifdef USESTRINGCACHE} + TAttributeEntryValue = TStringId; + {$else} + TAttributeEntryValue = string; + {$endif} - TAttributeEntry = TPair; + TAttributeEntry = TPair; PAttributeEntry = ^TAttributeEntry; TSyntaxNodeClass = class of TSyntaxNode; TSyntaxNode = class + {$ifdef USEBULKALLOCATOR} + strict private + class var FAllocator : TAllocator; + class constructor ClassCreate; + class destructor ClassDestroy; + public + class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override; + procedure FreeInstance; override; + {$endif} private FCol: Integer; FLine: Integer; @@ -32,6 +53,8 @@ TSyntaxNode = class function GetHasChildren: Boolean; function GetHasAttributes: Boolean; function TryGetAttributeEntry(const Key: TAttributeName; var AttributeEntry: PAttributeEntry): boolean; + procedure SetAttributeInternal(const Key: TAttributeName; const Value: TAttributeEntryValue); + {$ifdef USESTRINGCACHE}procedure SetAttribute(const Key: TAttributeName; const Value: TStringId); overload;{$endif} protected FAttributes: TArray; FChildNodes: TArray; @@ -46,7 +69,7 @@ TSyntaxNode = class function GetAttribute(const Key: TAttributeName): string; function HasAttribute(const Key: TAttributeName): Boolean; - procedure SetAttribute(const Key: TAttributeName; const Value: string); + procedure SetAttribute(const Key: TAttributeName; const Value: string); {$ifdef USESTRINGCACHE}overload;{$endif} procedure ClearAttributes; function AddChild(Node: TSyntaxNode): TSyntaxNode; overload; @@ -69,6 +92,15 @@ TSyntaxNode = class end; TCompoundSyntaxNode = class(TSyntaxNode) + {$ifdef USEBULKALLOCATOR} + strict private + class var FAllocator : TAllocator; + class constructor ClassCreate; + class destructor ClassDestroy; + public + class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override; + procedure FreeInstance; override; + {$endif} private FEndCol: Integer; FEndLine: Integer; @@ -80,15 +112,35 @@ TCompoundSyntaxNode = class(TSyntaxNode) end; TValuedSyntaxNode = class(TSyntaxNode) + {$ifdef USEBULKALLOCATOR} + strict private + class var FAllocator : TAllocator; + class constructor ClassCreate; + class destructor ClassDestroy; + public + class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override; + procedure FreeInstance; override; + {$endif} private - FValue: string; + FValue: {$ifdef USESTRINGCACHE}TStringId{$else}string{$endif}; + function GetValue: string; + procedure SetValue(const Value: string); public function Clone: TSyntaxNode; override; - property Value: string read FValue write FValue; + property Value: string read GetValue write SetValue; end; TCommentNode = class(TSyntaxNode) + {$ifdef USEBULKALLOCATOR} + strict private + class var FAllocator : TAllocator; + class constructor ClassCreate; + class destructor ClassDestroy; + public + class function NewInstance: TObject {$IFDEF AUTOREFCOUNT} unsafe {$ENDIF}; override; + procedure FreeInstance; override; + {$endif} private FText: string; public @@ -349,7 +401,51 @@ class procedure TExpressionTools.RawNodeListToTree(RawParentNode: TSyntaxNode; R { TSyntaxNode } +{$ifdef USEBULKALLOCATOR} + class constructor TSyntaxNode.ClassCreate; + begin + FAllocator := TAllocator.Create; + end; + + class destructor TSyntaxNode.ClassDestroy; + begin + FAllocator.Free; + end; + + class function TSyntaxNode.NewInstance: TObject; + begin + Result := InitInstance(FAllocator.New); + end; + + procedure TSyntaxNode.FreeInstance; + begin + CleanupInstance; + FAllocator.Return(Self); + end; +{$endif} + procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: string); +{$ifdef USESTRINGCACHE} + var + NewValue : TAttributeEntryValue; +{$endif} +begin + {$ifdef USESTRINGCACHE} + NewValue := TStringCache.Instance.Add(Value); + SetAttributeInternal(Key, NewValue); + {$else} + SetAttributeInternal(Key, Value); + {$endif} +end; + +{$ifdef USESTRINGCACHE} + procedure TSyntaxNode.SetAttribute(const Key: TAttributeName; const Value: TStringId); + begin + SetAttributeInternal(Key, Value); + end; +{$endif} + +procedure TSyntaxNode.SetAttributeInternal(const Key: TAttributeName; const Value: TAttributeEntryValue); var AttributeEntry: PAttributeEntry; len: Integer; @@ -416,6 +512,11 @@ constructor TSyntaxNode.Create(Typ: TSyntaxNodeType); begin inherited Create; FTyp := Typ; + SetLength(FAttributes, 0); + SetLength(FChildNodes, 0); + FParentNode := nil; + + {$ifdef USESTRINGCACHE}TStringCache.Instance.IncRef;{$endif} end; procedure TSyntaxNode.ExtractChild(Node: TSyntaxNode); @@ -442,8 +543,14 @@ destructor TSyntaxNode.Destroy; var i: integer; begin - for i := 0 to High(FChildNodes) do - FreeAndNil(FChildNodes[i]); + {$ifdef USESTRINGCACHE}TStringCache.Instance.DecRef;{$endif} + + for i := 0 to Length(FChildNodes) - 1 do + FChildNodes[i].Free; + SetLength(FChildNodes, 0); + + SetLength(FAttributes, 0); + inherited; end; @@ -462,7 +569,11 @@ function TSyntaxNode.GetAttribute(const Key: TAttributeName): string; AttributeEntry: PAttributeEntry; begin if TryGetAttributeEntry(Key, AttributeEntry) then - Result := AttributeEntry^.Value + {$ifdef USESTRINGCACHE} + Result := TStringCache.Instance.Get(AttributeEntry^.Value) + {$else} + Result := AttributeEntry^.Value + {$endif} else Result := ''; end; @@ -498,6 +609,29 @@ procedure TSyntaxNode.AssignPositionFrom(const Node: TSyntaxNode); { TCompoundSyntaxNode } +{$ifdef USEBULKALLOCATOR} + class constructor TCompoundSyntaxNode.ClassCreate; + begin + FAllocator := TAllocator.Create; + end; + + class destructor TCompoundSyntaxNode.ClassDestroy; + begin + FAllocator.Free; + end; + + class function TCompoundSyntaxNode.NewInstance: TObject; + begin + Result := InitInstance(FAllocator.New); + end; + + procedure TCompoundSyntaxNode.FreeInstance; + begin + CleanupInstance; + FAllocator.Return(Self); + end; +{$endif} + function TCompoundSyntaxNode.Clone: TSyntaxNode; begin Result := inherited; @@ -508,6 +642,29 @@ function TCompoundSyntaxNode.Clone: TSyntaxNode; { TValuedSyntaxNode } +{$ifdef USEBULKALLOCATOR} + class constructor TValuedSyntaxNode.ClassCreate; + begin + FAllocator := TAllocator.Create; + end; + + class destructor TValuedSyntaxNode.ClassDestroy; + begin + FAllocator.Free; + end; + + class function TValuedSyntaxNode.NewInstance: TObject; + begin + Result := InitInstance(FAllocator.New); + end; + + procedure TValuedSyntaxNode.FreeInstance; + begin + CleanupInstance; + FAllocator.Return(Self); + end; +{$endif} + function TValuedSyntaxNode.Clone: TSyntaxNode; begin Result := inherited; @@ -515,8 +672,49 @@ function TValuedSyntaxNode.Clone: TSyntaxNode; TValuedSyntaxNode(Result).Value := Self.Value; end; +function TValuedSyntaxNode.GetValue: string; +begin + {$ifdef USESTRINGCACHE} + Result := TStringCache.Instance.Get(FValue); + {$else} + Result := FValue; + {$endif} +end; + +procedure TValuedSyntaxNode.SetValue(const Value: string); +begin + {$ifdef USESTRINGCACHE} + FValue := TStringCache.Instance.Add(Value); + {$else} + FValue := Value; + {$endif} +end; + { TCommentNode } +{$ifdef USEBULKALLOCATOR} + class constructor TCommentNode.ClassCreate; + begin + FAllocator := TAllocator.Create; + end; + + class destructor TCommentNode.ClassDestroy; + begin + FAllocator.Free; + end; + + class function TCommentNode.NewInstance: TObject; + begin + Result := InitInstance(FAllocator.New); + end; + + procedure TCommentNode.FreeInstance; + begin + CleanupInstance; + FAllocator.Return(Self); + end; +{$endif} + function TCommentNode.Clone: TSyntaxNode; begin Result := inherited; @@ -534,4 +732,4 @@ constructor EParserException.Create(Line, Col: Integer; const FileName, Msg: str FCol := Col; end; -end. \ No newline at end of file +end. diff --git a/Source/DelphiAST.Serialize.Binary.pas b/Source/DelphiAST.Serialize.Binary.pas index 8ce7ce34..caec721d 100644 --- a/Source/DelphiAST.Serialize.Binary.pas +++ b/Source/DelphiAST.Serialize.Binary.pas @@ -307,6 +307,7 @@ function TBinarySerializer.WriteString(const S: string): Boolean; i: Integer; id: integer; u8: UTF8String; + Buffer : Pointer; begin Result := false; @@ -324,9 +325,11 @@ function TBinarySerializer.WriteString(const S: string): Boolean; i := Length(u8); if not WriteNumber(i) then Exit; - if i > 0 then - if FStream.Write(@(u8[1]), i) <> i then + if i > 0 then begin + Buffer := @(u8[1]); + if FStream.Write(Buffer, i) <> i then Exit; + end; end; Result := true; diff --git a/Source/DelphiAST.Writer.pas b/Source/DelphiAST.Writer.pas index 6ef53dbd..268ae118 100644 --- a/Source/DelphiAST.Writer.pas +++ b/Source/DelphiAST.Writer.pas @@ -23,8 +23,9 @@ TSyntaxTreeWriter = class implementation uses - Generics.Collections, - DelphiAST.Consts, DelphiAST.Serialize.Binary; + Generics.Collections, DelphiAST.Consts, + {$ifdef USESTRINGCACHE}SimpleParser.StringCache,{$endif} + DelphiAST.Serialize.Binary; {$I SimpleParser.inc} {$IFDEF D18_NEWER} @@ -67,7 +68,7 @@ class procedure TSyntaxTreeWriter.NodeToXML(const Builder: TStringBuilder; var HasChildren: Boolean; NewIndent: string; - Attr: TPair; + Attr: TPair; ChildNode: TSyntaxNode; begin HasChildren := Node.HasChildren; @@ -97,7 +98,13 @@ class procedure TSyntaxTreeWriter.NodeToXML(const Builder: TStringBuilder; Builder.Append(' value="' + XMLEncode(TValuedSyntaxNode(Node).Value) + '"'); for Attr in Node.Attributes do - Builder.Append(' ' + AttributeNameStrings[Attr.Key] + '="' + XMLEncode(Attr.Value) + '"'); + Builder.Append(' ' + AttributeNameStrings[Attr.Key] + '="' + {$ifdef USESTRINGCACHE} + + XMLEncode(TStringCache.Instance.Get(Attr.Value)) + {$else} + + XMLEncode(Attr.Value) + {$endif} + + '"'); if HasChildren then Builder.Append('>') else diff --git a/Source/SimpleParser/SimpleParser.Lexer.pas b/Source/SimpleParser/SimpleParser.Lexer.pas index d0181b8d..2a3c45aa 100644 --- a/Source/SimpleParser/SimpleParser.Lexer.pas +++ b/Source/SimpleParser/SimpleParser.Lexer.pas @@ -381,7 +381,8 @@ TmwPasLex = class(TmwBasePasLex) implementation uses - StrUtils; + StrUtils + {$ifdef USESTRINGCACHE}, SimpleParser.StringCache{$endif}; type TmwPasLexExpressionEvaluation = (leeNone, leeAnd, leeOr); @@ -1297,10 +1298,18 @@ constructor TmwBasePasLex.Create; New(FBuffer); FillChar(FBuffer^, SizeOf(TBufferRec), 0); + + {$ifdef USESTRINGCACHE} + TStringCache.Instance.IncRef; + {$endif} end; destructor TmwBasePasLex.Destroy; begin + {$ifdef USESTRINGCACHE} + TStringCache.Instance.DecRef; + {$endif} + if not FBuffer.SharedBuffer then FreeMem(FBuffer.Buf); @@ -2300,7 +2309,11 @@ function TmwBasePasLex.GetIsSpace: Boolean; function TmwBasePasLex.GetToken: string; begin - SetString(Result, FBuffer.Buf + FTokenPos, TokenLen); + {$ifdef USESTRINGCACHE} + Result := TStringCache.Instance.AddAndGet(FBuffer.Buf + FTokenPos, TokenLen); + {$else} + SetString(Result, (FBuffer.Buf + FTokenPos), TokenLen); + {$endif} end; function TmwBasePasLex.GetTokenLen: Integer; diff --git a/Source/SimpleParser/SimpleParser.ObjectAllocator.pas b/Source/SimpleParser/SimpleParser.ObjectAllocator.pas new file mode 100644 index 00000000..13fddcd2 --- /dev/null +++ b/Source/SimpleParser/SimpleParser.ObjectAllocator.pas @@ -0,0 +1,149 @@ +unit SimpleParser.ObjectAllocator; + +{ + Object bulk allocator, to assist in preventing memory fragmentation over time. + Allocates large chunks of memory, and classes can implement NewInstance to + get a piece of it. Freeing should similarly return the memory back to the pool. + In this implementation, memory is never returned to the OS until the process + shuts down - if objects are allocated and freed frequently enough that a pool + prevents fragmentation, keeping the memory allocated for the subsequent times + round is a good strategy. Some bookkeeping could track when an entire OS + allocation is unused and return it. + + Originally written by David Millington: vintagedave@gmail.com or dave@parnassus.co + See https://parnassus.co/custom-object-memory-allocation-in-delphi-bypassing-fastmm-for-fun-and-profit/ + for an overview. + Code donated to the DelphiAST project, April 2016. +} + +interface + +uses + System.Generics.Collections; + +{.$define COUNT_ALLOCATIONS} + +type + TAllocator = class + private + FInstanceSizeBytes : NativeUInt; + FBulkAllocSizeBytes : NativeUInt; + FIndividualObjects : TStack; + FBulkAllocations : TStack; + {$ifdef COUNT_ALLOCATIONS} + FNumNews, + FNumReturns, + FNumBulkAllocs : Int64; + {$endif} + const NUM_ALLOCS : NativeUInt = 4096 * 4; + procedure BulkAllocate; + public + constructor Create; + destructor Destroy; override; + + function New : Pointer; + procedure Return(const P : Pointer); + end; + +implementation + +uses + Winapi.Windows; + +{ TAllocator } + +constructor TAllocator.Create; +begin + inherited; + + FInstanceSizeBytes := TClass(T).InstanceSize; + FBulkAllocSizeBytes := FInstanceSizeBytes * NUM_ALLOCS; // 4K blocks in Windows, so alloc several of them + + FIndividualObjects := TStack.Create; + FIndividualObjects.Capacity := NUM_ALLOCS; + FBulkAllocations := TStack.Create; + FBulkAllocations.Capacity := 16; + + {$ifdef COUNT_ALLOCATIONS} + FNumNews := 0; + FNumReturns := 0; + FNumBulkAllocs := 0; + {$endif} + + BulkAllocate; +end; + +destructor TAllocator.Destroy; +var + P : Pointer; +begin + {$ifdef COUNT_ALLOCATIONS} + assert(FNumNews = FNumReturns); // Otherwise objects leaked + {$endif} + + FIndividualObjects.Clear; + + // Free all bulk allocs + while FBulkAllocations.Count > 0 do + VirtualFree(FBulkAllocations.Pop, 0, MEM_RELEASE); + + FBulkAllocations.Clear; + + FIndividualObjects.Free; + FBulkAllocations.Free; + + inherited; +end; + +procedure TAllocator.BulkAllocate; +var + P : Pointer; + Item : NativeUInt; + I : Integer; +begin + P := VirtualAlloc(nil, FBulkAllocSizeBytes, MEM_COMMIT or MEM_RESERVE, PAGE_EXECUTE_READWRITE); + FBulkAllocations.Push(P); + + // Now, split into a set of pointers which can become individual objects, ie + // checks of memory FInstanceSize big each + Item := NativeUInt(P); + while Item < NativeUInt(P) + FBulkAllocSizeBytes do begin + FIndividualObjects.Push(Pointer(Item)); + Inc(Item, FInstanceSizeBytes); + end; + assert(Item = NativeUInt(P) + FBulkAllocSizeBytes); + + {$ifdef COUNT_ALLOCATIONS} + Inc(FNumBulkAllocs); + {$endif} +end; + +function TAllocator.New: Pointer; +begin + {$ifdef COUNT_ALLOCATIONS} + try + {$endif} + + if FIndividualObjects.Count = 0 then + BulkAllocate; + + Result := FIndividualObjects.Pop; + ZeroMemory(Result, FInstanceSizeBytes); + + {$ifdef COUNT_ALLOCATIONS} + finally + Inc(FNumNews); + end; + {$endif} +end; + +procedure TAllocator.Return(const P: Pointer); +begin + FIndividualObjects.Push(P); + + {$ifdef COUNT_ALLOCATIONS} + Inc(FNumReturns); + {$endif} +end; + +end. diff --git a/Source/SimpleParser/SimpleParser.StringCache.pas b/Source/SimpleParser/SimpleParser.StringCache.pas new file mode 100644 index 00000000..21547316 --- /dev/null +++ b/Source/SimpleParser/SimpleParser.StringCache.pas @@ -0,0 +1,331 @@ +unit SimpleParser.StringCache; + +{ + String cache: provides a global class to keep unique string instances, which + are then referred to by an ID. There are methods to then get a string given + an ID. This can greatly reduce the number of strings in memory, since all + strings with the same content will be the same actual string, stored in the + cache. + + Originally written by David Millington: vintagedave@gmail.com or dave@parnassus.co + Code donated to the DelphiAST project, April 2016. +} + +interface + +uses + System.Generics.Defaults, System.Generics.Collections, SyncObjs; + +// Use STRINGCACHE_THREADSAFE to ensure one instance can be accessed by multiple +// threads at once. This prevents clearing - it keeps all added elements for the +// life of the instance (life of the program if using TStringCache.Instance) +// and locks around adding / getting items. +// This is one by default +{$define STRINGCACHE_THREADSAFE} + +type + TStringId = type NativeInt; + + TStringCache = class + type + TStringRec = class + strict private + FValue : string; + FUsageCount : NativeUInt; + public + constructor Create(const AValue : string); + procedure IncUsageCount; + property UsageCount : NativeUInt read FUsageCount; + property Value : string read FValue; + end; + private + type + TStringRecValueEqualityComparer = class(TEqualityComparer) + private + FStringComparer : IEqualityComparer; + public + constructor Create(); + function Equals(const Left, Right: TStringRec): Boolean; overload; override; + function GetHashCode(const Value: TStringRec): Integer; overload; override; + end; + TStringRecUsageComparer = class(TInterfacedObject, IComparer) + function Compare(const Left, Right: TStringRec): Integer; + end; + strict private + FStringToId : TDictionary; + FRefCount : NativeInt; + {$ifdef STRINGCACHE_THREADSAFE} + FLock : TCriticalSection; + {$else} + // If threadsafe, always persistent, so only allow it to be changed when not threadsafe + FIsPersistent : Boolean; + {$endif} + + class var FInstance : TStringCache; + class constructor ClassCreate; + class destructor ClassDestroy; + + procedure Lock; inline; + procedure Unlock; inline; + private + FIdToString : TList; + function GetIsPersistent: Boolean; + procedure SetIsPersistent(const Value: Boolean); // ID is index + public + constructor Create; + destructor Destroy; override; + + function Add(const Value : string) : TStringId; + function AddAndGet(const P : PChar; const Length : Integer) : string; + function Get(const ID : TStringId) : string; + procedure Clear(const OnDestruction : Boolean = false); + procedure ByUsage(InOrder : TList); + + procedure IncRef; + procedure DecRef; + + property Persistent : Boolean read GetIsPersistent write SetIsPersistent; + class property Instance : TStringCache read FInstance; + end; + +implementation + +uses + SysUtils, Types; + +{ TStringCache.TStringRecValueEqualityComparer } + +constructor TStringCache.TStringRecValueEqualityComparer.Create; +begin + inherited Create(); + FStringComparer := TEqualityComparer.Default; +end; + +function TStringCache.TStringRecValueEqualityComparer.Equals(const Left, + Right: TStringRec): Boolean; +begin + // Compare by the string it holds only + Result := FStringComparer.Equals(Left.Value, Right.Value); +end; + +function TStringCache.TStringRecValueEqualityComparer.GetHashCode( + const Value: TStringRec): Integer; +begin + // Compare by the string it holds only + Result := FStringComparer.GetHashCode(Value.Value); +end; + +{ TStringCache.TStringRecUsageComparer } + +function TStringCache.TStringRecUsageComparer.Compare(const Left, + Right: TStringRec): Integer; +begin + if Left.UsageCount < Right.UsageCount then + Exit(LessThanValue) + else if Left.UsageCount > Right.UsageCount then + Exit(GreaterThanValue) + else // Usage is the same, sort by string + Exit(TComparer.Default.Compare(Left.Value, Right.Value)); +end; + +{ TStringCache } + +class constructor TStringCache.ClassCreate; +begin + FInstance := TStringCache.Create; +end; + +class destructor TStringCache.ClassDestroy; +begin + FInstance.Free; +end; + +constructor TStringCache.Create; +begin + inherited; + FRefCount := 0; + {$ifdef STRINGCACHE_THREADSAFE} + FLock := TCriticalSection.Create; + {$else} + FIsPersistent := false; // Clear the cache when no longer needed + {$endif} + FStringToId := TDictionary.Create( + TStringCache.TStringRecValueEqualityComparer.Create); + FIdToString := TList.Create; + + Add(''); // Empty string is always item 0 +end; + +destructor TStringCache.Destroy; +begin + assert(FRefCount = 0, 'String cache destroyed with live objects still relying on it'); + Clear(true); + FStringToId.Free; + FIdToString.Free; + {$ifdef STRINGCACHE_THREADSAFE} + FLock.Free; + {$endif} + inherited; +end; + +function TStringCache.Add(const Value: string): TStringId; +var + Item : TStringRec; +begin + Result := 0; + Item := TStringRec.Create(Value); + + Lock; + try + if FStringToId.TryGetValue(Item, Result) then begin + // Already exists. Increment the usage count of the existing one, and return + FIdToString[Result].IncUsageCount; + Item.Free; // Already exists, Item was search key only + Exit; + end; + + // Item does not yet exist + Result := FIdToString.Add(Item); + FStringToId.Add(Item, Result); + finally + Unlock; + end; +end; + +function TStringCache.AddAndGet(const P : PChar; const Length : Integer) : string; +var + SearchStr : string; +begin + SetString(SearchStr, P, Length); + + Lock; // Will enter in Get and Add too, but a CS can be entered multiple times + try + Result := Get(Add(SearchStr)); + finally + Unlock; + end; +end; + +function TStringCache.Get(const ID: TStringId): string; +begin + Lock; + try + if ID < FIdToString.Count then + Exit(FIdToString[ID].Value) + else + raise Exception.Create(Format('String cache entry with ID %d does not exist', [ID])); + finally + Unlock; + end; +end; + +procedure TStringCache.Clear(const OnDestruction : Boolean); +var + I : Integer; +begin + // This doesn't need a lock. When threadsafe, never cleared except on destruction + + if FRefCount <> 0 then + raise Exception.Create(Format('Clearing the string cache while objects still rely on it (%d)', [FRefCount])); + + // One instance of TStringRec, but stored in two lists. Free from only one + for I := 0 to Pred(FIdToString.Count) do + FIdToString[I].Free; + + FStringToId.Clear; + FIdToString.Clear; + + if not OnDestruction then begin + // Add emtpy string - it's always item 0 - unless this is being called as + // part of destruction + Add(''); + assert(Get(0) = ''); + end; +end; + +procedure TStringCache.ByUsage(InOrder: TList); +begin + Lock; + try + InOrder.InsertRange(0, FIdToString); + InOrder.Sort(TStringCache.TStringRecUsageComparer.Create); + finally + Unlock; + end; +end; + +function TStringCache.GetIsPersistent: Boolean; +begin + {$ifdef STRINGCACHE_THREADSAFE} + Result := true; // Never clears + {$else} + Result := FIsPersistent; + {$endif} +end; + +procedure TStringCache.SetIsPersistent(const Value: Boolean); +begin + // If threadsafe, always persistent (never clears) so don't set anything + {$ifndef STRINGCACHE_THREADSAFE} + FIsPersistent := Value; + {$endif} +end; + +procedure TStringCache.IncRef; +begin + // Keep a count of how many objects are using the string cache. This lets it + // clear itself when the last one is freed - ie, free all the strings when + // they are no longer needed. (The alternative, controlled by Persistent, + // is to keep them - ie make the cache persistent over multiple runs - useful + // for parsing the same or similar files over and over.) + AtomicIncrement(FRefCount); +end; + +procedure TStringCache.DecRef; +begin + if AtomicDecrement(FRefCount) < 0 then + raise Exception.Create('String cache refcount cannot be decremented below zero'); + + // When threadsafe, synchronizing clearing while ensuring the refcount is 0 + // (ie an addref dosn't occur while clearing) is hard without locking around + // IncRef and DecRef, which is expensive. So just don't clear. + {$ifndef STRINGCACHE_THREADSAFE} + // Unless want to keep the strings around for next parse, clear now nothing is + // using any of them. + if (FRefCount = 0) and (not Persistent) then + Clear; + {$endif} +end; + +procedure TStringCache.Lock; +begin + // If not threadsafe, nothing to do here + {$ifdef STRINGCACHE_THREADSAFE} + FLock.Acquire; + {$endif} +end; + +procedure TStringCache.Unlock; +begin + // If not threadsafe, nothing to do here + {$ifdef STRINGCACHE_THREADSAFE} + FLock.Release; + {$endif} +end; + + +{ TStringCache.TStringRec } + +constructor TStringCache.TStringRec.Create(const AValue: string); +begin + inherited Create; + FValue := AValue; + FUsageCount := 1; +end; + +procedure TStringCache.TStringRec.IncUsageCount; +begin + Inc(FUsageCount); +end; + +end.