1 {
2 *****************************************************************************
3 This file is part of the Lazarus Component Library (LCL)
4
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8
9 Author: Mattias Gaertner
10
11 Abstract:
12 Defines TLCLMemManager, which is the base class for various
13 memory managers in the lcl and its interfaces.
14 An own memory manager is somewhat faster and makes debugging and
15 profiling easier.
16 }
17 unit LCLMemManager;
18
19 {$mode objfpc}{$H+}
20
21 interface
22
23 uses
24 Classes, Math;
25
26 type
27 PLCLMemManagerItem = ^TLCLMemManagerItem;
28 TLCLMemManagerItem = record
29 Next: PLCLMemManagerItem;
30 end;
31
32 { memory manager template }
33
34 TLCLMemManager = class
35 private
36 procedure SetMaxFreeRatio(NewValue: integer);
37 procedure SetMinFree(NewValue: integer);
38 protected
39 FFirstFree: PLCLMemManagerItem;
40 FFreeCount: integer;
41 FCount: integer;
42 FMinFree: integer;
43 FMaxFreeRatio: integer;
44 FAllocatedCount: int64;
45 FFreedCount: int64;
46 procedure DisposeItem(AnItem: PLCLMemManagerItem);
NewItemnull47 function NewItem: PLCLMemManagerItem;
48 procedure FreeFirstItem; virtual;
49 public
50 property MinimumFreeCount: integer read FMinFree write SetMinFree;
51 property MaximumFreeCountRatio: integer
52 read FMaxFreeRatio write SetMaxFreeRatio; // in one eighth steps
53 property Count: integer read FCount;
54 property FreeCount: integer read FFreeCount;
55 property AllocatedCount: int64 read FAllocatedCount;
56 property FreedCount: int64 read FFreedCount;
57 procedure Clear;
58 constructor Create;
59 destructor Destroy; override;
60 end;
61
62
63 { TLCLNonFreeMemManager - a memory manager for records without freeing }
64
65 TLCLEnumItemsMethod = procedure(Item: Pointer) of object;
66
67 TLCLNonFreeMemManager = class
68 private
69 FItemSize: PtrInt;
70 FItems: TFPList;
71 FCurItem: Pointer;
72 FEndItem: Pointer;
73 FCurSize: PtrInt;
74 FFirstSize: PtrInt;
75 FMaxItemsPerChunk: PtrInt;
76 public
77 ClearOnCreate: boolean;
78 property ItemSize: PtrInt read FItemSize;
79 property MaxItemsPerChunk: PtrInt read FMaxItemsPerChunk write FMaxItemsPerChunk;
80 procedure Clear;
81 constructor Create(TheItemSize: integer);
82 destructor Destroy; override;
NewItemnull83 function NewItem: Pointer;
84 procedure EnumerateItems(const Method: TLCLEnumItemsMethod);
85 end;
86
87 {$IF FPC_FULLVERSION>20402}
88 TStreamSizeType = PtrInt;
89 {$ELSE}
90 TStreamSizeType = Longint;
91 {$IFEND}
92
93 { TExtMemoryStream }
94
95 TExtMemoryStream = class(TMemoryStream)
96 protected
Reallocnull97 function Realloc(var NewCapacity: TStreamSizeType): Pointer; override;
98 public
99 property Capacity;
100 end;
101
102
103 implementation
104
105 {$IFOpt R+}{$Define RangeChecksOn}{$Endif}
106
107 { TLCLMemManager }
108
109 procedure TLCLMemManager.Clear;
110 begin
111 while FFirstFree<>nil do begin
112 FreeFirstItem;
113 inc(FFreedCount);
114 end;
115 FFreeCount:=0;
116 end;
117
118 constructor TLCLMemManager.Create;
119 begin
120 inherited Create;
121 FFirstFree:=nil;
122 FFreeCount:=0;
123 FCount:=0;
124 FAllocatedCount:=0;
125 FFreedCount:=0;
126 FMinFree:=100000;
127 FMaxFreeRatio:=8; // 1:1
128 end;
129
130 destructor TLCLMemManager.Destroy;
131 begin
132 Clear;
133 inherited Destroy;
134 end;
135
136 procedure TLCLMemManager.DisposeItem(AnItem: PLCLMemManagerItem);
137 begin
138 if AnItem<>nil then begin
139 if (FFreeCount<FMinFree) or (FFreeCount<((FCount shr 3)*FMaxFreeRatio)) then
140 begin
141 // add ANode to Free list
142 //AddItemToFreeList(AnItem);
143 inc(FFreeCount);
144 end else begin
145 // free list full -> free the ANode
146 //FreeItem(AnItem);
147 {$R-}
148 inc(FFreedCount);
149 {$IfDef RangeChecksOn}{$R+}{$Endif}
150 end;
151 dec(FCount);
152 end;
153 end;
154
TLCLMemManager.NewItemnull155 function TLCLMemManager.NewItem: PLCLMemManagerItem;
156 begin
157 if FFirstFree<>nil then begin
158 // take from free list
159 Result:=FFirstFree;
160 FFirstFree:=FFirstFree^.Next;
161 Result^.Next:=nil;
162 dec(FFreeCount);
163 end else begin
164 // free list empty -> create new node
165 New(Result);
166 {$R-}
167 inc(FAllocatedCount);
168 {$IfDef RangeChecksOn}{$R+}{$Endif}
169 end;
170 inc(FCount);
171 end;
172
173 procedure TLCLMemManager.SetMaxFreeRatio(NewValue: integer);
174 begin
175 if NewValue<0 then NewValue:=0;
176 if NewValue=FMaxFreeRatio then exit;
177 FMaxFreeRatio:=NewValue;
178 end;
179
180 procedure TLCLMemManager.SetMinFree(NewValue: integer);
181 begin
182 if NewValue<0 then NewValue:=0;
183 if NewValue=FMinFree then exit;
184 FMinFree:=NewValue;
185 end;
186
187 procedure TLCLMemManager.FreeFirstItem;
188 var Item: PLCLMemManagerItem;
189 begin
190 Item:=FFirstFree;
191 FFirstFree:=FFirstFree^.Next;
192 Dispose(Item);
193 end;
194
195 { TLCLNonFreeMemManager }
196
197 procedure TLCLNonFreeMemManager.Clear;
198 var
199 i: Integer;
200 p: Pointer;
201 begin
202 if FItems<>nil then begin
203 for i:=0 to FItems.Count-1 do begin
204 p:=FItems[i];
205 FreeMem(p);
206 end;
207 FItems.Free;
208 FItems:=nil;
209 end;
210 FCurItem:=nil;
211 FEndItem:=nil;
212 FCurSize:=FItemSize*4; // 4 items
213 end;
214
215 constructor TLCLNonFreeMemManager.Create(TheItemSize: integer);
216 begin
217 FItemSize:=TheItemSize;
218 FFirstSize:=FItemSize*4; // 4 items => the first item has 8 entries
219 FCurSize:=FFirstSize;
220 end;
221
222 destructor TLCLNonFreeMemManager.Destroy;
223 begin
224 Clear;
225 inherited Destroy;
226 end;
227
NewItemnull228 function TLCLNonFreeMemManager.NewItem: Pointer;
229 begin
230 if (FCurItem=FEndItem) then begin
231 // each item has double the size of its predecessor
232 inc(FCurSize,FCurSize);
233 if (FMaxItemsPerChunk>0) and (FCurSize>FMaxItemsPerChunk*FItemSize) then
234 FCurSize:=FMaxItemsPerChunk*FItemSize;
235 GetMem(FCurItem,FCurSize);
236 if ClearOnCreate then
237 FillChar(FCurItem^,FCurSize,0);
238 if FItems=nil then FItems:=TFPList.Create;
239 FItems.Add(FCurItem);
240 FEndItem := FCurItem;
241 Inc(FEndItem, FCurSize);
242 end;
243 Result:=FCurItem;
244 Inc(FCurItem, FItemSize);
245 end;
246
247 procedure TLCLNonFreeMemManager.EnumerateItems(
248 const Method: TLCLEnumItemsMethod);
249 var
250 Cnt: Integer;
251 i: Integer;
252 p: Pointer;
253 Size: Integer;
254 Last: Pointer;
255 begin
256 if FItems<>nil then begin
257 Cnt:=FItems.Count;
258 Size:=FFirstSize;
259 for i:=0 to Cnt-1 do begin
260 // each item has double the size of its predecessor
261 inc(Size,Size);
262 p:=FItems[i];
263 Last := p;
264 Inc(Last, Size);
265 if i=Cnt-1 then
266 Last:=FEndItem;
267 while p<>Last do begin
268 Method(p);
269 Inc(p, FItemSize);
270 end;
271 end;
272 end;
273 end;
274
275 { TExtMemoryStream }
276
Reallocnull277 function TExtMemoryStream.Realloc(var NewCapacity: TStreamSizeType): Pointer;
278 begin
279 // if we are growing, grow at least a quarter
280 if (NewCapacity > Capacity) then
281 NewCapacity := Max(NewCapacity, Capacity + Capacity div 4);
282 Result := inherited Realloc(NewCapacity);
283 end;
284
285 end.
286
287