1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2003, Ada Core Technologies, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- GNATMEM is a utility that tracks memory leaks. It is based on a simple
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:
35 -- $ gnatmake my_prog -largs -lgmem
37 -- The running my_prog will produce a file named gmem.out that will be
40 -- - Record a reference to the allocated memory on each allocation call.
42 -- - Suppress this reference on deallocation.
44 -- - At the end of the program, remaining references are potential leaks.
45 -- sort them out the best possible way in order to locate the root of
48 -- This capability is not supported on all platforms, please refer to
49 -- memtrack.adb for further information.
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
54 -- number of allocations, amount of memory allocated, high water mark, etc.)
56 with GNAT.Command_Line; use GNAT.Command_Line;
57 with Ada.Text_IO; use Ada.Text_IO;
58 with Ada.Float_Text_IO;
59 with Ada.Integer_Text_IO;
60 with Gnatvsn; use Gnatvsn;
61 with GNAT.Heap_Sort_G;
62 with GNAT.OS_Lib; use GNAT.OS_Lib;
63 with GNAT.HTable; use GNAT.HTable;
64 with System; use System;
65 with System.Storage_Elements; use System.Storage_Elements;
67 with Memroot; use Memroot;
71 ------------------------
72 -- Other Declarations --
73 ------------------------
75 type Storage_Elmt is record
77 -- * = End of log file
78 -- A = found a ALLOC mark in the log
79 -- D = found a DEALL mark in the log
80 Address : Integer_Address;
83 -- This needs a comment ???
85 Log_Name, Program_Name : String_Access;
86 -- These need comments, and should be on separate lines ???
88 function Read_Next return Storage_Elmt;
89 -- Reads next dynamic storage operation from the log file.
91 function Mem_Image (X : Storage_Count) return String;
92 -- X is a size in storage_element. Returns a value
93 -- in Megabytes, Kilobytes or Bytes as appropriate.
95 procedure Process_Arguments;
96 -- Read command line arguments
99 -- Prints out the option help
101 function Gmem_Initialize (Dumpname : String) return Boolean;
102 -- Opens the file represented by Dumpname and prepares it for
103 -- work. Returns False if the file does not have the correct format, True
106 procedure Gmem_A2l_Initialize (Exename : String);
107 -- Initialises the convert_addresses interface by supplying it with
108 -- the name of the executable file Exename
110 -----------------------------------
111 -- HTable address --> Allocation --
112 -----------------------------------
114 type Allocation is record
116 Size : Storage_Count;
119 type Address_Range is range 0 .. 4097;
120 function H (A : Integer_Address) return Address_Range;
121 No_Alloc : constant Allocation := (No_Root_Id, 0);
123 package Address_HTable is new GNAT.HTable.Simple_HTable (
124 Header_Num => Address_Range,
125 Element => Allocation,
126 No_Element => No_Alloc,
127 Key => Integer_Address,
131 BT_Depth : Integer := 1;
133 -- The following need comments ???
135 Global_Alloc_Size : Storage_Count := 0;
136 Global_High_Water_Mark : Storage_Count := 0;
137 Global_Nb_Alloc : Integer := 0;
138 Global_Nb_Dealloc : Integer := 0;
139 Nb_Root : Integer := 0;
140 Nb_Wrong_Deall : Integer := 0;
141 Minimum_NB_Leaks : Integer := 1;
143 Tmp_Alloc : Allocation;
144 Quiet_Mode : Boolean := False;
146 -------------------------------
147 -- Allocation roots sorting --
148 -------------------------------
150 Sort_Order : String (1 .. 3) := "nwh";
151 -- This is the default order in which sorting criteria will be applied
152 -- n - Total number of unfreed allocations
153 -- w - Final watermark
154 -- h - High watermark
156 --------------------------------
157 -- GMEM functionality binding --
158 --------------------------------
160 function Gmem_Initialize (Dumpname : String) return Boolean is
161 function Initialize (Dumpname : System.Address) return Boolean;
162 pragma Import (C, Initialize, "__gnat_gmem_initialize");
164 S : aliased String := Dumpname & ASCII.NUL;
167 return Initialize (S'Address);
170 procedure Gmem_A2l_Initialize (Exename : String) is
171 procedure A2l_Initialize (Exename : System.Address);
172 pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
174 S : aliased String := Exename & ASCII.NUL;
177 A2l_Initialize (S'Address);
178 end Gmem_A2l_Initialize;
180 function Read_Next return Storage_Elmt is
181 procedure Read_Next (buf : System.Address);
182 pragma Import (C, Read_Next, "__gnat_gmem_read_next");
187 Read_Next (S'Address);
195 function H (A : Integer_Address) return Address_Range is
197 return Address_Range (A mod Integer_Address (Address_Range'Last));
204 function Mem_Image (X : Storage_Count) return String is
205 Ks : constant Storage_Count := X / 1024;
206 Megs : constant Storage_Count := Ks / 1024;
207 Buff : String (1 .. 7);
211 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
212 return Buff & " Megabytes";
215 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
216 return Buff & " Kilobytes";
219 Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
220 return Buff (1 .. 4) & " Bytes";
232 Put (Gnat_Version_String);
233 Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
236 Put_Line ("Usage: gnatmem switches [depth] exename");
238 Put_Line (" depth backtrace depth to take into account, default is"
239 & Integer'Image (BT_Depth));
240 Put_Line (" exename the name of the executable to be analyzed");
242 Put_Line ("Switches:");
243 Put_Line (" -b n same as depth parameter");
244 Put_Line (" -i file read the allocation log from specific file");
245 Put_Line (" default is gmem.out in the current directory");
246 Put_Line (" -m n masks roots with less than n leaks, default is 1");
247 Put_Line (" specify 0 to see even released allocation roots");
248 Put_Line (" -q quiet, minimum output");
249 Put_Line (" -s order sort allocation roots according to an order of");
250 Put_Line (" sort criteria");
251 GNAT.OS_Lib.OS_Exit (1);
254 -----------------------
255 -- Process_Arguments --
256 -----------------------
258 procedure Process_Arguments is
260 -- Parse the options first
263 case Getopt ("b: m: i: q s:") is
264 when ASCII.Nul => exit;
268 BT_Depth := Natural'Value (Parameter);
270 when Constraint_Error =>
276 Minimum_NB_Leaks := Natural'Value (Parameter);
278 when Constraint_Error =>
283 Log_Name := new String'(Parameter);
290 S : String (Sort_Order'Range) := Parameter;
292 for J in Sort_Order'Range loop
293 if S (J) = 'n' or else S (J) = 'w'
294 or else S (J) = 'h' then
295 Sort_Order (J) := S (J);
297 raise Constraint_Error;
301 when Constraint_Error =>
302 Put_Line ("Invalid sort criteria string.");
303 GNAT.OS_Lib.OS_Exit (1);
311 -- Set default log file if -i hasn't been specified
313 if Log_Name = null then
314 Log_Name := new String'("gmem.out");
317 -- Get the optional backtrace length and program name
320 Str1 : constant String := GNAT.Command_Line.Get_Argument;
321 Str2 : constant String := GNAT.Command_Line.Get_Argument;
329 Program_Name := new String'(Str1);
331 BT_Depth := Natural'Value (Str1);
332 Program_Name := new String'(Str2);
336 when Constraint_Error =>
340 -- Ensure presence of executable suffix in Program_Name
343 Suffix : String_Access := Get_Executable_Suffix;
350 (Program_Name.all'Last - Suffix.all'Length + 1 ..
351 Program_Name.all'Last) /= Suffix.all
353 Tmp := new String'(Program_Name.all & Suffix.all);
360 -- Search the executable on the path. If not found in the PATH, we
361 -- default to the current directory. Otherwise, libaddr2line will
362 -- fail with an error:
364 -- (null): Bad address
366 Tmp := Locate_Exec_On_Path (Program_Name.all);
369 Tmp := new String'('.' & Directory_Separator & Program_Name.all);
376 if not Is_Regular_File (Log_Name.all) then
377 Put_Line ("Couldn't find " & Log_Name.all);
378 GNAT.OS_Lib.OS_Exit (1);
381 if not Gmem_Initialize (Log_Name.all) then
382 Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
383 GNAT.OS_Lib.OS_Exit (1);
386 if not Is_Regular_File (Program_Name.all) then
387 Put_Line ("Couldn't find " & Program_Name.all);
390 Gmem_A2l_Initialize (Program_Name.all);
393 when GNAT.Command_Line.Invalid_Switch =>
394 Ada.Text_IO.Put_Line ("Invalid switch : "
395 & GNAT.Command_Line.Full_Switch);
397 end Process_Arguments;
399 Cur_Elmt : Storage_Elmt;
401 -- Start of processing for Gnatmem
406 -- Main loop analysing the data generated by the instrumented routines.
407 -- For each allocation, the backtrace is kept and stored in a htable
408 -- whose entry is the address. For each deallocation, we look for the
409 -- corresponding allocation and cancel it.
412 Cur_Elmt := Read_Next;
414 case Cur_Elmt.Elmt is
420 -- Update global counters if the allocated size is meaningful
423 Tmp_Alloc.Root := Read_BT (BT_Depth);
425 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
426 Nb_Root := Nb_Root + 1;
429 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
430 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
432 elsif Cur_Elmt.Size > 0 then
434 Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
435 Global_Nb_Alloc := Global_Nb_Alloc + 1;
437 if Global_High_Water_Mark < Global_Alloc_Size then
438 Global_High_Water_Mark := Global_Alloc_Size;
441 -- Read the corresponding back trace
443 Tmp_Alloc.Root := Read_BT (BT_Depth);
445 -- Update the number of allocation root if this is a new one
447 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
448 Nb_Root := Nb_Root + 1;
451 -- Update allocation root specific counters
453 Set_Alloc_Size (Tmp_Alloc.Root,
454 Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
456 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
458 if High_Water_Mark (Tmp_Alloc.Root) <
459 Alloc_Size (Tmp_Alloc.Root)
461 Set_High_Water_Mark (Tmp_Alloc.Root,
462 Alloc_Size (Tmp_Alloc.Root));
465 -- Associate this allocation root to the allocated address
467 Tmp_Alloc.Size := Cur_Elmt.Size;
468 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
470 -- non meaningful output, just consumes the backtrace
473 Tmp_Alloc.Root := Read_BT (BT_Depth);
478 -- Get the corresponding Dealloc_Size and Root
480 Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
482 if Tmp_Alloc.Root = No_Root_Id then
484 -- There was no prior allocation at this address, something is
485 -- very wrong. Mark this allocation root as problematic
487 Tmp_Alloc.Root := Read_BT (BT_Depth);
489 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
490 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
491 Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
495 -- Update global counters
497 if not Quiet_Mode then
498 Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
501 Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
503 -- Update allocation root specific counters
505 if not Quiet_Mode then
506 Set_Alloc_Size (Tmp_Alloc.Root,
507 Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
510 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
512 -- update the number of allocation root if this one disappear
514 if Nb_Alloc (Tmp_Alloc.Root) = 0
515 and then Minimum_NB_Leaks > 0 then
516 Nb_Root := Nb_Root - 1;
519 -- De-associate the deallocated address
521 Address_HTable.Remove (Cur_Elmt.Address);
529 -- Print out general information about overall allocation
531 if not Quiet_Mode then
532 Put_Line ("Global information");
533 Put_Line ("------------------");
535 Put (" Total number of allocations :");
536 Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
539 Put (" Total number of deallocations :");
540 Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
543 Put_Line (" Final Water Mark (non freed mem) :"
544 & Mem_Image (Global_Alloc_Size));
545 Put_Line (" High Water Mark :"
546 & Mem_Image (Global_High_Water_Mark));
550 -- Print out the back traces corresponding to potential leaks in order
551 -- greatest number of non-deallocated allocations
553 Print_Back_Traces : declare
554 type Root_Array is array (Natural range <>) of Root_Id;
555 Leaks : Root_Array (0 .. Nb_Root);
556 Leak_Index : Natural := 0;
558 Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
559 Deall_Index : Natural := 0;
560 Nb_Alloc_J : Natural := 0;
562 procedure Move (From : Natural; To : Natural);
563 function Lt (Op1, Op2 : Natural) return Boolean;
564 package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
566 procedure Move (From : Natural; To : Natural) is
568 Leaks (To) := Leaks (From);
571 function Lt (Op1, Op2 : Natural) return Boolean is
572 function Apply_Sort_Criterion (S : Character) return Integer;
573 -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
574 -- smaller than, equal, or greater than Op2 according to criterion
576 function Apply_Sort_Criterion (S : Character) return Integer is
577 LOp1, LOp2 : Integer;
581 LOp1 := Nb_Alloc (Leaks (Op1));
582 LOp2 := Nb_Alloc (Leaks (Op2));
585 LOp1 := Integer (Alloc_Size (Leaks (Op1)));
586 LOp2 := Integer (Alloc_Size (Leaks (Op2)));
589 LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
590 LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
593 return 0; -- Can't actually happen
598 elsif LOp1 > LOp2 then
604 when Constraint_Error =>
606 end Apply_Sort_Criterion;
611 for S in Sort_Order'Range loop
612 Result := Apply_Sort_Criterion (Sort_Order (S));
615 elsif Result = 1 then
622 -- Start of processing for Print_Back_Traces
625 -- Transfer all the relevant Roots in the Leaks and a
626 -- Bogus_Deall arrays
628 Tmp_Alloc.Root := Get_First;
629 while Tmp_Alloc.Root /= No_Root_Id loop
630 if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 0 then
633 elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
634 Deall_Index := Deall_Index + 1;
635 Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
638 Leak_Index := Leak_Index + 1;
639 Leaks (Leak_Index) := Tmp_Alloc.Root;
642 Tmp_Alloc.Root := Get_Next;
645 -- Print out wrong deallocations
647 if Nb_Wrong_Deall > 0 then
648 Put_Line ("Releasing deallocated memory at :");
649 if not Quiet_Mode then
650 Put_Line ("--------------------------------");
653 for J in 1 .. Bogus_Dealls'Last loop
654 Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
659 -- Print out all allocation Leaks
663 -- Sort the Leaks so that potentially important leaks appear first
665 Root_Sort.Sort (Nb_Root);
667 for J in 1 .. Leaks'Last loop
668 Nb_Alloc_J := Nb_Alloc (Leaks (J));
669 if Nb_Alloc_J >= Minimum_NB_Leaks then
671 if Nb_Alloc_J = 1 then
672 Put_Line (" 1 leak at :");
674 Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
678 Put_Line ("Allocation Root #" & Integer'Image (J));
679 Put_Line ("-------------------");
681 Put (" Number of non freed allocations :");
682 Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
686 (" Final Water Mark (non freed mem) :"
687 & Mem_Image (Alloc_Size (Leaks (J))));
690 (" High Water Mark :"
691 & Mem_Image (High_Water_Mark (Leaks (J))));
693 Put_Line (" Backtrace :");
696 Print_BT (Leaks (J), Short => Quiet_Mode);
701 end Print_Back_Traces;