1 {
2 *****************************************************************************
3 * *
4 * This file is part of the ZCAD *
5 * *
6 * See the file COPYING.modifiedLGPL.txt, included in this distribution, *
7 * for details about the copyright. *
8 * *
9 * This program is distributed in the hope that it will be useful, *
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
12 * *
13 *****************************************************************************
14 }
15 {
16 @author(Andrey Zubarev <zamtmn@yandex.ru>)
17 }
18
19 unit uzbmemman;
20 {$INCLUDE def.inc}
21 interface
22 uses LCLProc,uzbtypesbase,sysutils;
23
24 //const firstarraysize=100;
25
remapmememblocknull26 function remapmememblock({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}pblock: GDBPointer; sizeblock: GDBInteger): GDBPointer;
enlargememblocknull27 function enlargememblock({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}pblock: GDBPointer; oldsize, nevsize: GDBInteger): GDBPointer;
28 procedure GDBGetMem({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}out p:Pointer; const size: GDBLongWord); export;
29 procedure GDBFreeMem(var p: Pointer);
30 //procedure startup;
31 //procedure Finalize;
32 const getmemmax=9000000;
33 type
34 memdesk=record
35 free:GDBBoolean;
36 getmemguid:String;
37 addr:pointer;
38 size:GDBLongword;
39 end;
40 var
41 memdeskarr:array [0..getmemmax] of memdesk;
42 memdesktotal,memdeskfree,i2:GDBInteger;
43 GetMemCount,FreeMemCount:GDBInteger;
44 TotalAlloc,CurrentAlloc:int64;
45 TotalAllocMb,CurrentAllocMB:GDBInteger;
46 lastallocated:GDBLongWord;
47 lasti:integer;
48 debp:pointer;
49 {$IFDEF DEBUGBUILD}
50 var
51 size,i:integer;
52 s:gdbstring;
53 {$ENDIF}
54
55 implementation
56 {$IFNDEF DEBUGBUILD}
57 //uses log;
58 {$ENDIF}
59 {$IFDEF DEBUGBUILD}
60 uses gvector;
61 type
62 TFreememDesk={GDBOpenArrayOfByte}TVector<integer>;
63 var
64 freememdesk:TFreememDesk;
65
66 {$ENDIF}
67
68 procedure GDBGetMem({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}out p:Pointer; const size: GDBLongWord);
69 {$IFDEF DEBUGBUILD}var i:GDBInteger;{$ENDIF}
70 begin
71 getmem(p, size);
72 {$IFDEF FILL0ALLOCATEDMEMORY}
73 fillchar(p^,size,0);
74 {$ENDIF}
75 inc(GetMemCount);
76 TotalAlloc:=TotalAlloc+size;
77 CurrentAlloc:=CurrentAlloc+size;
78 TotalAllocMB:=TotalAlloc div 1024;
79 {$IFDEF DEBUGBUILD}
80 if memdeskfree>0 then
81 begin
82 i:=freememdesk.Back;freememdesk.PopBack;//PopData(@i,sizeof(i));
83 //for i:=0 to memdesktotal do
84 begin
85 if memdeskarr[i].free then
86 begin
87 dec(memdeskfree);
88 memdeskarr[i].free:=false;
89 memdeskarr[i].getmemguid:=ErrGuid;
90 memdeskarr[i].addr:=p;
91 memdeskarr[i].size:=size;
92
93 lastallocated:=longword(p);
94 lasti:=i;
95 if i=7019 then
96 begin
97 inc(i2);
98 if i2=14 then
99 i2:=i2;
100 end;
101 //break;
102 end
103 else
104 memdeskfree:=memdeskfree;
105 end;
106 end
107
108 else
109 begin
110 inc(memdesktotal);
111
112 if memdesktotal=7019 then
113 begin
114 i2:=i2;
115 end;
116
117 memdeskarr[memdesktotal].free:=false;
118 memdeskarr[memdesktotal].getmemguid:=ErrGuid;
119 memdeskarr[memdesktotal].addr:=p;
120 memdeskarr[memdesktotal].size:=size;
121 lastallocated:=longword(p);
122 lasti:=memdesktotal;
123 end;
124 if size=0 then
125 begin
126 debugln('{F}ERROR:GDBGetMem(0)');
127 //programlog.LogOutStr('ERROR:GDBGetMem(0)',0,LM_Fatal);
128 {$IFDEF BREACKPOINTSONERRORS}
129 asm
130 //int 3;
131 end;
132 {$ENDIF}
133 end;
134 {$ENDIF}
135 end;
136 procedure GDBFreeMem(var p: Pointer) export;
137 {$IFDEF DEBUGBUILD}var i:GDBInteger;{$ENDIF}
138 begin
139 inc(FreeMemCount);
140 {$IFDEF DEBUGBUILD}
141 if p=nil then
142 begin
143 debugln('{F}ERROR:GDBFreeMem(nil)');
144 //programlog.LogOutStr('ERROR:GDBFreeMem(nil)',0,LM_Error);
145 {$IFDEF BREACKPOINTSONERRORS}
146 asm
147 int 3;
148 end;
149 {$ENDIF}
150
151 end;
152 if lastallocated<>GDBLongword(p) then
153 begin
154 for i:=memdesktotal downto 0 do
155 begin
156 if memdeskarr[i].addr=p then
157 begin
158 if lasti<>-2 then
159 freememdesk.PushBack(i);
160 //freememdesk.AddData(@i,sizeof(i));
161 memdeskarr[i].free:=true;
162 memdeskarr[i].getmemguid:='Freed';
163 memdeskarr[i].addr:=0;
164 CurrentAlloc:=CurrentAlloc-memdeskarr[i].size;
165 CurrentAllocMB:=CurrentAlloc div 1024;
166 if i=memdesktotal then
167 dec(memdesktotal)
168 else
169 inc(memdeskfree);
170 break;
171 end
172 end;
173 end
174 else
175 begin
176 memdeskarr[lasti].free:=true;
177 memdeskarr[lasti].getmemguid:='Freed';
178 memdeskarr[lasti].addr:=0;
179 CurrentAlloc:=CurrentAlloc-memdeskarr[lasti].size;
180 CurrentAllocMB:=CurrentAlloc div 1024;
181 //inc(memdeskfree);
182 if lasti=memdesktotal then
183 dec(memdesktotal)
184 else
185 begin
186 inc(memdeskfree);
187 freememdesk.PushBack(lasti); //AddData(@lasti,sizeof(lasti));
188 end;
189 lastallocated:=0;
190 end;
191 {$ENDIF}
192 {$IFDEF BREACKPOINTSONERRORS}
193 //if (p)=debp then
194 // asm
195 // int 3;
196 // end;
197 {$ENDIF}
198 if p<> nil then freemem(p);
199 p:=nil;
200 end;
remapmememblocknull201 function remapmememblock({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}pblock: GDBPointer; sizeblock: GDBInteger): GDBPointer;
202 var
203 newblock: GDBPointer;
204 begin
205 newblock:=nil;
206 GDBGetMem({$IFDEF DEBUGBUILD}ErrGuid,{$ENDIF}newblock, sizeblock);
207 Move(pblock^, newblock^, sizeblock);
208 result := newblock;
209 GDBFreeMem(pblock);
210 end;
enlargememblocknull211 function enlargememblock({$IFDEF DEBUGBUILD}ErrGuid:pansichar;{$ENDIF}pblock: GDBPointer; oldsize, nevsize: GDBInteger): GDBPointer;
212 var
213 newblock: GDBPointer;
214 begin
215 newblock:=nil;
216 GDBGetMem({$IFDEF DEBUGBUILD}ErrGuid,{$ENDIF}newblock, nevsize);
217 Move(pblock^, newblock^, oldsize);
218 result := newblock;
219 GDBFreeMem(pblock);
220 end;
221 procedure startup;
222 begin
223 GetMemCount:=0;
224 FreeMemCount:=0;
225 TotalAlloc:=0;
226 i2:=0;
227 end;
228 initialization
229 begin
230 memdesktotal:=-1;
231 memdeskfree:=0;
232 lasti:=-1;
233 {$IFDEF DEBUGBUILD}
234 freememdesk:=TFreememDesk.create;
235 {$ENDIF}
236 end;
237 finalization;
238 begin
239 {$IFDEF DEBUGBUILD}
240 lasti:=-2;
241 freememdesk.Destroy;
242 //freememdesk.done;
243 size:=0;
244 //s:='GetMemCount= '+inttostr(GetMemCount);
245 //LogOut(s);
246 debugln('{I}GetMemCount=%d',[GetMemCount]);
247 //s:='FreeMemCount='+inttostr(FreeMemCount);
248 //LogOut(s);
249 debugln('{I}FreeMemCount=%d',[FreeMemCount]);
250 //s:='TotalAlloc= '+inttostr(TotalAlloc);
251 //LogOut(s);
252 debugln('{I}TotalAlloc=%d',[TotalAlloc]);
253 for i:=0 to memdesktotal do
254 begin
255 if not memdeskarr[i].free then
256 begin
257 //s:='Not freed GDBGetMem with GUID='+memdeskarr[i].getmemguid+' #='+inttostr(i)+' addr='+inttohex(memdeskarr[i].addr,8)+' size='+inttostr(memdeskarr[i].size);
258 //LogOut(s);
259 debugln('{E}Not freed GDBGetMem with GUID=%s #=%d addr=%p size=%d',[memdeskarr[i].getmemguid,i,memdeskarr[i].addr,memdeskarr[i].size]);
260 size:=size+memdeskarr[i].size;
261 end;
262 end;
263 //if size>0 then
264 begin
265 debugln('{I}Total not freed memory=%d',[size]);
266 //s:='Total not freed memory='+inttostr(size);
267 //LogOut(s);
268 end;
269 {$ENDIF}
270 end;
271 end.
272