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