]>
Commit | Line | Data |
---|---|---|
38cbfe40 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- G N A T M E M -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
448f2610 | 9 | -- Copyright (C) 1997-2005, Ada Core Technologies, Inc. -- |
38cbfe40 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
18 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
38cbfe40 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | -- GNATMEM is a utility that tracks memory leaks. It is based on a simple | |
28 | -- idea: | |
fbf5a39b AC |
29 | |
30 | -- - Read the allocation log generated by the application linked using | |
31 | -- instrumented memory allocation and dealocation (see memtrack.adb for | |
32 | -- this circuitry). To get access to this functionality, the application | |
33 | -- must be relinked with library libgmem.a: | |
34 | ||
35 | -- $ gnatmake my_prog -largs -lgmem | |
36 | ||
37 | -- The running my_prog will produce a file named gmem.out that will be | |
38 | -- parsed by gnatmem. | |
39 | ||
448f2610 | 40 | -- - Record a reference to the allocated memory on each allocation call |
fbf5a39b | 41 | |
448f2610 | 42 | -- - Suppress this reference on deallocation |
fbf5a39b AC |
43 | |
44 | -- - At the end of the program, remaining references are potential leaks. | |
38cbfe40 RK |
45 | -- sort them out the best possible way in order to locate the root of |
46 | -- the leak. | |
fbf5a39b AC |
47 | |
48 | -- This capability is not supported on all platforms, please refer to | |
49 | -- memtrack.adb for further information. | |
50 | ||
38cbfe40 RK |
51 | -- In order to help finding out the real leaks, the notion of "allocation |
52 | -- root" is defined. An allocation root is a specific point in the program | |
53 | -- execution generating memory allocation where data is collected (such as | |
fbf5a39b | 54 | -- number of allocations, amount of memory allocated, high water mark, etc.) |
38cbfe40 | 55 | |
91b1417d AC |
56 | with Gnatvsn; use Gnatvsn; |
57 | ||
38cbfe40 | 58 | with Ada.Text_IO; use Ada.Text_IO; |
38cbfe40 RK |
59 | with Ada.Float_Text_IO; |
60 | with Ada.Integer_Text_IO; | |
91b1417d AC |
61 | |
62 | with GNAT.Command_Line; use GNAT.Command_Line; | |
38cbfe40 | 63 | with GNAT.Heap_Sort_G; |
fbf5a39b | 64 | with GNAT.OS_Lib; use GNAT.OS_Lib; |
38cbfe40 | 65 | with GNAT.HTable; use GNAT.HTable; |
91b1417d | 66 | |
38cbfe40 RK |
67 | with System; use System; |
68 | with System.Storage_Elements; use System.Storage_Elements; | |
69 | ||
70 | with Memroot; use Memroot; | |
71 | ||
72 | procedure Gnatmem is | |
73 | ||
38cbfe40 RK |
74 | ------------------------ |
75 | -- Other Declarations -- | |
76 | ------------------------ | |
77 | ||
fbf5a39b AC |
78 | type Storage_Elmt is record |
79 | Elmt : Character; | |
80 | -- * = End of log file | |
81 | -- A = found a ALLOC mark in the log | |
82 | -- D = found a DEALL mark in the log | |
83 | Address : Integer_Address; | |
84 | Size : Storage_Count; | |
85 | end record; | |
86 | -- This needs a comment ??? | |
38cbfe40 | 87 | |
fbf5a39b AC |
88 | Log_Name, Program_Name : String_Access; |
89 | -- These need comments, and should be on separate lines ??? | |
38cbfe40 | 90 | |
fbf5a39b | 91 | function Read_Next return Storage_Elmt; |
448f2610 | 92 | -- Reads next dynamic storage operation from the log file |
38cbfe40 RK |
93 | |
94 | function Mem_Image (X : Storage_Count) return String; | |
95 | -- X is a size in storage_element. Returns a value | |
fbf5a39b | 96 | -- in Megabytes, Kilobytes or Bytes as appropriate. |
38cbfe40 RK |
97 | |
98 | procedure Process_Arguments; | |
fbf5a39b | 99 | -- Read command line arguments |
38cbfe40 RK |
100 | |
101 | procedure Usage; | |
102 | -- Prints out the option help | |
103 | ||
104 | function Gmem_Initialize (Dumpname : String) return Boolean; | |
105 | -- Opens the file represented by Dumpname and prepares it for | |
106 | -- work. Returns False if the file does not have the correct format, True | |
107 | -- otherwise. | |
108 | ||
109 | procedure Gmem_A2l_Initialize (Exename : String); | |
110 | -- Initialises the convert_addresses interface by supplying it with | |
111 | -- the name of the executable file Exename | |
112 | ||
38cbfe40 RK |
113 | ----------------------------------- |
114 | -- HTable address --> Allocation -- | |
115 | ----------------------------------- | |
116 | ||
117 | type Allocation is record | |
118 | Root : Root_Id; | |
119 | Size : Storage_Count; | |
120 | end record; | |
121 | ||
122 | type Address_Range is range 0 .. 4097; | |
123 | function H (A : Integer_Address) return Address_Range; | |
124 | No_Alloc : constant Allocation := (No_Root_Id, 0); | |
125 | ||
126 | package Address_HTable is new GNAT.HTable.Simple_HTable ( | |
127 | Header_Num => Address_Range, | |
128 | Element => Allocation, | |
129 | No_Element => No_Alloc, | |
130 | Key => Integer_Address, | |
131 | Hash => H, | |
132 | Equal => "="); | |
133 | ||
134 | BT_Depth : Integer := 1; | |
fbf5a39b AC |
135 | |
136 | -- The following need comments ??? | |
38cbfe40 RK |
137 | |
138 | Global_Alloc_Size : Storage_Count := 0; | |
139 | Global_High_Water_Mark : Storage_Count := 0; | |
140 | Global_Nb_Alloc : Integer := 0; | |
141 | Global_Nb_Dealloc : Integer := 0; | |
142 | Nb_Root : Integer := 0; | |
143 | Nb_Wrong_Deall : Integer := 0; | |
fbf5a39b AC |
144 | Minimum_NB_Leaks : Integer := 1; |
145 | ||
38cbfe40 RK |
146 | Tmp_Alloc : Allocation; |
147 | Quiet_Mode : Boolean := False; | |
148 | ||
15ce9ca2 AC |
149 | ------------------------------ |
150 | -- Allocation Roots Sorting -- | |
151 | ------------------------------ | |
fbf5a39b AC |
152 | |
153 | Sort_Order : String (1 .. 3) := "nwh"; | |
154 | -- This is the default order in which sorting criteria will be applied | |
155 | -- n - Total number of unfreed allocations | |
156 | -- w - Final watermark | |
157 | -- h - High watermark | |
158 | ||
38cbfe40 RK |
159 | -------------------------------- |
160 | -- GMEM functionality binding -- | |
161 | -------------------------------- | |
162 | ||
163 | function Gmem_Initialize (Dumpname : String) return Boolean is | |
164 | function Initialize (Dumpname : System.Address) return Boolean; | |
165 | pragma Import (C, Initialize, "__gnat_gmem_initialize"); | |
fbf5a39b | 166 | |
38cbfe40 | 167 | S : aliased String := Dumpname & ASCII.NUL; |
fbf5a39b | 168 | |
38cbfe40 RK |
169 | begin |
170 | return Initialize (S'Address); | |
171 | end Gmem_Initialize; | |
172 | ||
173 | procedure Gmem_A2l_Initialize (Exename : String) is | |
174 | procedure A2l_Initialize (Exename : System.Address); | |
175 | pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize"); | |
fbf5a39b | 176 | |
38cbfe40 | 177 | S : aliased String := Exename & ASCII.NUL; |
fbf5a39b | 178 | |
38cbfe40 RK |
179 | begin |
180 | A2l_Initialize (S'Address); | |
181 | end Gmem_A2l_Initialize; | |
182 | ||
fbf5a39b | 183 | function Read_Next return Storage_Elmt is |
38cbfe40 RK |
184 | procedure Read_Next (buf : System.Address); |
185 | pragma Import (C, Read_Next, "__gnat_gmem_read_next"); | |
38cbfe40 | 186 | |
fbf5a39b | 187 | S : Storage_Elmt; |
38cbfe40 RK |
188 | |
189 | begin | |
fbf5a39b AC |
190 | Read_Next (S'Address); |
191 | return S; | |
192 | end Read_Next; | |
38cbfe40 RK |
193 | |
194 | ------- | |
195 | -- H -- | |
196 | ------- | |
197 | ||
198 | function H (A : Integer_Address) return Address_Range is | |
199 | begin | |
200 | return Address_Range (A mod Integer_Address (Address_Range'Last)); | |
201 | end H; | |
202 | ||
38cbfe40 RK |
203 | --------------- |
204 | -- Mem_Image -- | |
205 | --------------- | |
206 | ||
207 | function Mem_Image (X : Storage_Count) return String is | |
208 | Ks : constant Storage_Count := X / 1024; | |
209 | Megs : constant Storage_Count := Ks / 1024; | |
210 | Buff : String (1 .. 7); | |
211 | ||
212 | begin | |
213 | if Megs /= 0 then | |
214 | Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0); | |
215 | return Buff & " Megabytes"; | |
216 | ||
217 | elsif Ks /= 0 then | |
218 | Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0); | |
219 | return Buff & " Kilobytes"; | |
220 | ||
221 | else | |
222 | Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X)); | |
fbf5a39b | 223 | return Buff (1 .. 4) & " Bytes"; |
38cbfe40 RK |
224 | end if; |
225 | end Mem_Image; | |
226 | ||
227 | ----------- | |
228 | -- Usage -- | |
229 | ----------- | |
230 | ||
231 | procedure Usage is | |
232 | begin | |
233 | New_Line; | |
19f0526a | 234 | Put ("GNATMEM "); |
5f8abbd9 | 235 | Put_Line (Gnat_Version_String); |
448f2610 | 236 | Put_Line ("Copyright 1997-2005 Free Software Foundation, Inc."); |
38cbfe40 RK |
237 | New_Line; |
238 | ||
fbf5a39b AC |
239 | Put_Line ("Usage: gnatmem switches [depth] exename"); |
240 | New_Line; | |
241 | Put_Line (" depth backtrace depth to take into account, default is" | |
242 | & Integer'Image (BT_Depth)); | |
243 | Put_Line (" exename the name of the executable to be analyzed"); | |
244 | New_Line; | |
245 | Put_Line ("Switches:"); | |
246 | Put_Line (" -b n same as depth parameter"); | |
247 | Put_Line (" -i file read the allocation log from specific file"); | |
248 | Put_Line (" default is gmem.out in the current directory"); | |
249 | Put_Line (" -m n masks roots with less than n leaks, default is 1"); | |
250 | Put_Line (" specify 0 to see even released allocation roots"); | |
38cbfe40 | 251 | Put_Line (" -q quiet, minimum output"); |
fbf5a39b AC |
252 | Put_Line (" -s order sort allocation roots according to an order of"); |
253 | Put_Line (" sort criteria"); | |
38cbfe40 RK |
254 | GNAT.OS_Lib.OS_Exit (1); |
255 | end Usage; | |
256 | ||
257 | ----------------------- | |
258 | -- Process_Arguments -- | |
259 | ----------------------- | |
260 | ||
261 | procedure Process_Arguments is | |
38cbfe40 | 262 | begin |
fbf5a39b | 263 | -- Parse the options first |
38cbfe40 | 264 | |
fbf5a39b AC |
265 | loop |
266 | case Getopt ("b: m: i: q s:") is | |
267 | when ASCII.Nul => exit; | |
38cbfe40 | 268 | |
fbf5a39b AC |
269 | when 'b' => |
270 | begin | |
271 | BT_Depth := Natural'Value (Parameter); | |
272 | exception | |
273 | when Constraint_Error => | |
274 | Usage; | |
275 | end; | |
38cbfe40 | 276 | |
fbf5a39b AC |
277 | when 'm' => |
278 | begin | |
279 | Minimum_NB_Leaks := Natural'Value (Parameter); | |
280 | exception | |
281 | when Constraint_Error => | |
282 | Usage; | |
283 | end; | |
38cbfe40 | 284 | |
fbf5a39b AC |
285 | when 'i' => |
286 | Log_Name := new String'(Parameter); | |
38cbfe40 | 287 | |
fbf5a39b AC |
288 | when 'q' => |
289 | Quiet_Mode := True; | |
38cbfe40 | 290 | |
fbf5a39b AC |
291 | when 's' => |
292 | declare | |
91b1417d AC |
293 | S : constant String (Sort_Order'Range) := Parameter; |
294 | ||
fbf5a39b AC |
295 | begin |
296 | for J in Sort_Order'Range loop | |
91b1417d AC |
297 | if S (J) = 'n' or else |
298 | S (J) = 'w' or else | |
299 | S (J) = 'h' | |
300 | then | |
fbf5a39b AC |
301 | Sort_Order (J) := S (J); |
302 | else | |
91b1417d AC |
303 | Put_Line ("Invalid sort criteria string."); |
304 | GNAT.OS_Lib.OS_Exit (1); | |
fbf5a39b AC |
305 | end if; |
306 | end loop; | |
fbf5a39b | 307 | end; |
38cbfe40 RK |
308 | |
309 | when others => | |
fbf5a39b | 310 | null; |
38cbfe40 | 311 | end case; |
38cbfe40 RK |
312 | end loop; |
313 | ||
fbf5a39b | 314 | -- Set default log file if -i hasn't been specified |
38cbfe40 | 315 | |
fbf5a39b AC |
316 | if Log_Name = null then |
317 | Log_Name := new String'("gmem.out"); | |
38cbfe40 RK |
318 | end if; |
319 | ||
fbf5a39b | 320 | -- Get the optional backtrace length and program name |
38cbfe40 | 321 | |
fbf5a39b AC |
322 | declare |
323 | Str1 : constant String := GNAT.Command_Line.Get_Argument; | |
324 | Str2 : constant String := GNAT.Command_Line.Get_Argument; | |
38cbfe40 | 325 | |
fbf5a39b AC |
326 | begin |
327 | if Str1 = "" then | |
38cbfe40 | 328 | Usage; |
38cbfe40 RK |
329 | end if; |
330 | ||
fbf5a39b AC |
331 | if Str2 = "" then |
332 | Program_Name := new String'(Str1); | |
333 | else | |
334 | BT_Depth := Natural'Value (Str1); | |
335 | Program_Name := new String'(Str2); | |
336 | end if; | |
38cbfe40 | 337 | |
fbf5a39b AC |
338 | exception |
339 | when Constraint_Error => | |
340 | Usage; | |
341 | end; | |
38cbfe40 | 342 | |
fbf5a39b | 343 | -- Ensure presence of executable suffix in Program_Name |
38cbfe40 | 344 | |
fbf5a39b AC |
345 | declare |
346 | Suffix : String_Access := Get_Executable_Suffix; | |
347 | Tmp : String_Access; | |
38cbfe40 RK |
348 | |
349 | begin | |
fbf5a39b AC |
350 | if Suffix.all /= "" |
351 | and then | |
352 | Program_Name.all | |
353 | (Program_Name.all'Last - Suffix.all'Length + 1 .. | |
354 | Program_Name.all'Last) /= Suffix.all | |
355 | then | |
356 | Tmp := new String'(Program_Name.all & Suffix.all); | |
357 | Free (Program_Name); | |
358 | Program_Name := Tmp; | |
359 | end if; | |
38cbfe40 | 360 | |
fbf5a39b | 361 | Free (Suffix); |
38cbfe40 | 362 | |
fbf5a39b AC |
363 | -- Search the executable on the path. If not found in the PATH, we |
364 | -- default to the current directory. Otherwise, libaddr2line will | |
365 | -- fail with an error: | |
38cbfe40 | 366 | |
fbf5a39b | 367 | -- (null): Bad address |
38cbfe40 | 368 | |
fbf5a39b | 369 | Tmp := Locate_Exec_On_Path (Program_Name.all); |
38cbfe40 | 370 | |
fbf5a39b AC |
371 | if Tmp = null then |
372 | Tmp := new String'('.' & Directory_Separator & Program_Name.all); | |
38cbfe40 RK |
373 | end if; |
374 | ||
fbf5a39b AC |
375 | Free (Program_Name); |
376 | Program_Name := Tmp; | |
377 | end; | |
38cbfe40 | 378 | |
fbf5a39b AC |
379 | if not Is_Regular_File (Log_Name.all) then |
380 | Put_Line ("Couldn't find " & Log_Name.all); | |
381 | GNAT.OS_Lib.OS_Exit (1); | |
382 | end if; | |
38cbfe40 | 383 | |
fbf5a39b AC |
384 | if not Gmem_Initialize (Log_Name.all) then |
385 | Put_Line ("File " & Log_Name.all & " is not a gnatmem log file"); | |
386 | GNAT.OS_Lib.OS_Exit (1); | |
387 | end if; | |
38cbfe40 | 388 | |
fbf5a39b AC |
389 | if not Is_Regular_File (Program_Name.all) then |
390 | Put_Line ("Couldn't find " & Program_Name.all); | |
391 | end if; | |
38cbfe40 | 392 | |
fbf5a39b | 393 | Gmem_A2l_Initialize (Program_Name.all); |
38cbfe40 | 394 | |
38cbfe40 | 395 | exception |
fbf5a39b AC |
396 | when GNAT.Command_Line.Invalid_Switch => |
397 | Ada.Text_IO.Put_Line ("Invalid switch : " | |
398 | & GNAT.Command_Line.Full_Switch); | |
399 | Usage; | |
400 | end Process_Arguments; | |
401 | ||
402 | Cur_Elmt : Storage_Elmt; | |
38cbfe40 RK |
403 | |
404 | -- Start of processing for Gnatmem | |
405 | ||
406 | begin | |
407 | Process_Arguments; | |
408 | ||
fbf5a39b AC |
409 | -- Main loop analysing the data generated by the instrumented routines. |
410 | -- For each allocation, the backtrace is kept and stored in a htable | |
411 | -- whose entry is the address. For each deallocation, we look for the | |
38cbfe40 RK |
412 | -- corresponding allocation and cancel it. |
413 | ||
414 | Main : loop | |
fbf5a39b AC |
415 | Cur_Elmt := Read_Next; |
416 | ||
417 | case Cur_Elmt.Elmt is | |
418 | when '*' => | |
38cbfe40 RK |
419 | exit Main; |
420 | ||
fbf5a39b | 421 | when 'A' => |
38cbfe40 RK |
422 | |
423 | -- Update global counters if the allocated size is meaningful | |
424 | ||
425 | if Quiet_Mode then | |
fbf5a39b AC |
426 | Tmp_Alloc.Root := Read_BT (BT_Depth); |
427 | ||
38cbfe40 RK |
428 | if Nb_Alloc (Tmp_Alloc.Root) = 0 then |
429 | Nb_Root := Nb_Root + 1; | |
430 | end if; | |
fbf5a39b | 431 | |
38cbfe40 | 432 | Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); |
fbf5a39b | 433 | Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); |
38cbfe40 | 434 | |
fbf5a39b | 435 | elsif Cur_Elmt.Size > 0 then |
38cbfe40 | 436 | |
fbf5a39b | 437 | Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size; |
38cbfe40 RK |
438 | Global_Nb_Alloc := Global_Nb_Alloc + 1; |
439 | ||
440 | if Global_High_Water_Mark < Global_Alloc_Size then | |
441 | Global_High_Water_Mark := Global_Alloc_Size; | |
442 | end if; | |
443 | ||
444 | -- Read the corresponding back trace | |
445 | ||
fbf5a39b | 446 | Tmp_Alloc.Root := Read_BT (BT_Depth); |
38cbfe40 RK |
447 | |
448 | -- Update the number of allocation root if this is a new one | |
449 | ||
450 | if Nb_Alloc (Tmp_Alloc.Root) = 0 then | |
451 | Nb_Root := Nb_Root + 1; | |
452 | end if; | |
453 | ||
454 | -- Update allocation root specific counters | |
455 | ||
456 | Set_Alloc_Size (Tmp_Alloc.Root, | |
fbf5a39b | 457 | Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size); |
38cbfe40 RK |
458 | |
459 | Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); | |
460 | ||
fbf5a39b AC |
461 | if High_Water_Mark (Tmp_Alloc.Root) < |
462 | Alloc_Size (Tmp_Alloc.Root) | |
38cbfe40 RK |
463 | then |
464 | Set_High_Water_Mark (Tmp_Alloc.Root, | |
465 | Alloc_Size (Tmp_Alloc.Root)); | |
466 | end if; | |
467 | ||
468 | -- Associate this allocation root to the allocated address | |
469 | ||
fbf5a39b AC |
470 | Tmp_Alloc.Size := Cur_Elmt.Size; |
471 | Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); | |
38cbfe40 | 472 | |
fbf5a39b | 473 | -- non meaningful output, just consumes the backtrace |
38cbfe40 RK |
474 | |
475 | else | |
fbf5a39b | 476 | Tmp_Alloc.Root := Read_BT (BT_Depth); |
38cbfe40 RK |
477 | end if; |
478 | ||
fbf5a39b | 479 | when 'D' => |
38cbfe40 RK |
480 | |
481 | -- Get the corresponding Dealloc_Size and Root | |
482 | ||
fbf5a39b | 483 | Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address); |
38cbfe40 RK |
484 | |
485 | if Tmp_Alloc.Root = No_Root_Id then | |
486 | ||
487 | -- There was no prior allocation at this address, something is | |
fbf5a39b | 488 | -- very wrong. Mark this allocation root as problematic |
38cbfe40 | 489 | |
fbf5a39b | 490 | Tmp_Alloc.Root := Read_BT (BT_Depth); |
38cbfe40 RK |
491 | |
492 | if Nb_Alloc (Tmp_Alloc.Root) = 0 then | |
493 | Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); | |
494 | Nb_Wrong_Deall := Nb_Wrong_Deall + 1; | |
495 | end if; | |
496 | ||
497 | else | |
498 | -- Update global counters | |
499 | ||
500 | if not Quiet_Mode then | |
501 | Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size; | |
502 | end if; | |
fbf5a39b | 503 | |
38cbfe40 RK |
504 | Global_Nb_Dealloc := Global_Nb_Dealloc + 1; |
505 | ||
506 | -- Update allocation root specific counters | |
507 | ||
508 | if not Quiet_Mode then | |
509 | Set_Alloc_Size (Tmp_Alloc.Root, | |
510 | Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size); | |
511 | end if; | |
fbf5a39b | 512 | |
38cbfe40 RK |
513 | Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); |
514 | ||
515 | -- update the number of allocation root if this one disappear | |
516 | ||
fbf5a39b AC |
517 | if Nb_Alloc (Tmp_Alloc.Root) = 0 |
518 | and then Minimum_NB_Leaks > 0 then | |
38cbfe40 RK |
519 | Nb_Root := Nb_Root - 1; |
520 | end if; | |
521 | ||
522 | -- De-associate the deallocated address | |
523 | ||
fbf5a39b | 524 | Address_HTable.Remove (Cur_Elmt.Address); |
38cbfe40 | 525 | end if; |
fbf5a39b AC |
526 | |
527 | when others => | |
528 | raise Program_Error; | |
38cbfe40 RK |
529 | end case; |
530 | end loop Main; | |
531 | ||
38cbfe40 RK |
532 | -- Print out general information about overall allocation |
533 | ||
534 | if not Quiet_Mode then | |
535 | Put_Line ("Global information"); | |
536 | Put_Line ("------------------"); | |
537 | ||
538 | Put (" Total number of allocations :"); | |
539 | Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4); | |
540 | New_Line; | |
541 | ||
542 | Put (" Total number of deallocations :"); | |
543 | Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4); | |
544 | New_Line; | |
545 | ||
546 | Put_Line (" Final Water Mark (non freed mem) :" | |
547 | & Mem_Image (Global_Alloc_Size)); | |
548 | Put_Line (" High Water Mark :" | |
549 | & Mem_Image (Global_High_Water_Mark)); | |
550 | New_Line; | |
551 | end if; | |
552 | ||
553 | -- Print out the back traces corresponding to potential leaks in order | |
554 | -- greatest number of non-deallocated allocations | |
555 | ||
556 | Print_Back_Traces : declare | |
557 | type Root_Array is array (Natural range <>) of Root_Id; | |
558 | Leaks : Root_Array (0 .. Nb_Root); | |
559 | Leak_Index : Natural := 0; | |
560 | ||
561 | Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall); | |
562 | Deall_Index : Natural := 0; | |
fbf5a39b | 563 | Nb_Alloc_J : Natural := 0; |
38cbfe40 RK |
564 | |
565 | procedure Move (From : Natural; To : Natural); | |
566 | function Lt (Op1, Op2 : Natural) return Boolean; | |
567 | package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt); | |
568 | ||
569 | procedure Move (From : Natural; To : Natural) is | |
570 | begin | |
571 | Leaks (To) := Leaks (From); | |
572 | end Move; | |
573 | ||
574 | function Lt (Op1, Op2 : Natural) return Boolean is | |
fbf5a39b AC |
575 | function Apply_Sort_Criterion (S : Character) return Integer; |
576 | -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is | |
577 | -- smaller than, equal, or greater than Op2 according to criterion | |
578 | ||
579 | function Apply_Sort_Criterion (S : Character) return Integer is | |
580 | LOp1, LOp2 : Integer; | |
581 | begin | |
582 | case S is | |
583 | when 'n' => | |
584 | LOp1 := Nb_Alloc (Leaks (Op1)); | |
585 | LOp2 := Nb_Alloc (Leaks (Op2)); | |
586 | ||
587 | when 'w' => | |
588 | LOp1 := Integer (Alloc_Size (Leaks (Op1))); | |
589 | LOp2 := Integer (Alloc_Size (Leaks (Op2))); | |
590 | ||
591 | when 'h' => | |
592 | LOp1 := Integer (High_Water_Mark (Leaks (Op1))); | |
593 | LOp2 := Integer (High_Water_Mark (Leaks (Op2))); | |
594 | ||
595 | when others => | |
596 | return 0; -- Can't actually happen | |
597 | end case; | |
598 | ||
599 | if LOp1 < LOp2 then | |
600 | return -1; | |
601 | elsif LOp1 > LOp2 then | |
602 | return 1; | |
603 | else | |
604 | return 0; | |
605 | end if; | |
606 | exception | |
607 | when Constraint_Error => | |
608 | return 0; | |
609 | end Apply_Sort_Criterion; | |
610 | ||
611 | Result : Integer; | |
612 | ||
91b1417d AC |
613 | -- Start of processing for Lt |
614 | ||
38cbfe40 | 615 | begin |
fbf5a39b AC |
616 | for S in Sort_Order'Range loop |
617 | Result := Apply_Sort_Criterion (Sort_Order (S)); | |
618 | if Result = -1 then | |
619 | return False; | |
620 | elsif Result = 1 then | |
621 | return True; | |
622 | end if; | |
623 | end loop; | |
624 | return False; | |
38cbfe40 RK |
625 | end Lt; |
626 | ||
627 | -- Start of processing for Print_Back_Traces | |
628 | ||
629 | begin | |
630 | -- Transfer all the relevant Roots in the Leaks and a | |
631 | -- Bogus_Deall arrays | |
632 | ||
633 | Tmp_Alloc.Root := Get_First; | |
634 | while Tmp_Alloc.Root /= No_Root_Id loop | |
fbf5a39b | 635 | if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 0 then |
38cbfe40 RK |
636 | null; |
637 | ||
638 | elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then | |
639 | Deall_Index := Deall_Index + 1; | |
640 | Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root; | |
641 | ||
642 | else | |
643 | Leak_Index := Leak_Index + 1; | |
644 | Leaks (Leak_Index) := Tmp_Alloc.Root; | |
645 | end if; | |
646 | ||
647 | Tmp_Alloc.Root := Get_Next; | |
648 | end loop; | |
649 | ||
650 | -- Print out wrong deallocations | |
651 | ||
652 | if Nb_Wrong_Deall > 0 then | |
653 | Put_Line ("Releasing deallocated memory at :"); | |
654 | if not Quiet_Mode then | |
655 | Put_Line ("--------------------------------"); | |
656 | end if; | |
657 | ||
658 | for J in 1 .. Bogus_Dealls'Last loop | |
fbf5a39b | 659 | Print_BT (Bogus_Dealls (J), Short => Quiet_Mode); |
38cbfe40 RK |
660 | New_Line; |
661 | end loop; | |
662 | end if; | |
663 | ||
664 | -- Print out all allocation Leaks | |
665 | ||
666 | if Nb_Root > 0 then | |
667 | ||
668 | -- Sort the Leaks so that potentially important leaks appear first | |
669 | ||
670 | Root_Sort.Sort (Nb_Root); | |
671 | ||
672 | for J in 1 .. Leaks'Last loop | |
fbf5a39b AC |
673 | Nb_Alloc_J := Nb_Alloc (Leaks (J)); |
674 | if Nb_Alloc_J >= Minimum_NB_Leaks then | |
675 | if Quiet_Mode then | |
676 | if Nb_Alloc_J = 1 then | |
677 | Put_Line (" 1 leak at :"); | |
678 | else | |
679 | Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :"); | |
680 | end if; | |
681 | ||
38cbfe40 | 682 | else |
fbf5a39b AC |
683 | Put_Line ("Allocation Root #" & Integer'Image (J)); |
684 | Put_Line ("-------------------"); | |
38cbfe40 | 685 | |
fbf5a39b AC |
686 | Put (" Number of non freed allocations :"); |
687 | Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4); | |
688 | New_Line; | |
689 | ||
690 | Put_Line | |
691 | (" Final Water Mark (non freed mem) :" | |
692 | & Mem_Image (Alloc_Size (Leaks (J)))); | |
38cbfe40 | 693 | |
fbf5a39b AC |
694 | Put_Line |
695 | (" High Water Mark :" | |
696 | & Mem_Image (High_Water_Mark (Leaks (J)))); | |
38cbfe40 | 697 | |
fbf5a39b AC |
698 | Put_Line (" Backtrace :"); |
699 | end if; | |
38cbfe40 | 700 | |
fbf5a39b AC |
701 | Print_BT (Leaks (J), Short => Quiet_Mode); |
702 | New_Line; | |
38cbfe40 | 703 | end if; |
38cbfe40 RK |
704 | end loop; |
705 | end if; | |
706 | end Print_Back_Traces; | |
38cbfe40 | 707 | end Gnatmem; |