1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2008, AdaCore --
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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- GNATMEM is a utility that tracks memory leaks. It is based on a simple
29 -- - Read the allocation log generated by the application linked using
30 -- instrumented memory allocation and deallocation (see memtrack.adb for
31 -- this circuitry). To get access to this functionality, the application
32 -- must be relinked with library libgmem.a:
34 -- $ gnatmake my_prog -largs -lgmem
36 -- The running my_prog will produce a file named gmem.out that will be
39 -- - Record a reference to the allocated memory on each allocation call
41 -- - Suppress this reference on deallocation
43 -- - At the end of the program, remaining references are potential leaks.
44 -- sort them out the best possible way in order to locate the root of
47 -- This capability is not supported on all platforms, please refer to
48 -- memtrack.adb for further information.
50 -- In order to help finding out the real leaks, the notion of "allocation
51 -- root" is defined. An allocation root is a specific point in the program
52 -- execution generating memory allocation where data is collected (such as
53 -- number of allocations, amount of memory allocated, high water mark, etc.)
55 with Ada.Float_Text_IO;
56 with Ada.Integer_Text_IO;
57 with Ada.Text_IO; use Ada.Text_IO;
59 with System; use System;
60 with System.Storage_Elements; use System.Storage_Elements;
62 with GNAT.Command_Line; use GNAT.Command_Line;
63 with GNAT.Heap_Sort_G;
64 with GNAT.OS_Lib; use GNAT.OS_Lib;
65 with GNAT.HTable; use GNAT.HTable;
67 with Gnatvsn; use Gnatvsn;
68 with Memroot; use Memroot;
72 package Int_IO renames Ada.Integer_Text_IO;
74 ------------------------
75 -- Other Declarations --
76 ------------------------
78 type Storage_Elmt is record
80 -- * = End of log file
81 -- A = found a ALLOC mark in the log
82 -- D = found a DEALL mark in the log
84 Address : Integer_Address;
88 -- This type is used to read heap operations from the log file.
89 -- Elmt contains the type of the operation, which can be either
90 -- allocation, deallocation, or a special mark indicating the
91 -- end of the log file. Address is used to store address on the
92 -- heap where a chunk was allocated/deallocated, size is only
93 -- for A event and contains size of the allocation, and Timestamp
94 -- is the clock value at the moment of allocation
96 Log_Name : String_Access;
97 -- Holds the name of the heap operations log file
99 Program_Name : String_Access;
100 -- Holds the name of the user executable
102 function Read_Next return Storage_Elmt;
103 -- Reads next dynamic storage operation from the log file
105 function Mem_Image (X : Storage_Count) return String;
106 -- X is a size in storage_element. Returns a value
107 -- in Megabytes, Kilobytes or Bytes as appropriate.
109 procedure Process_Arguments;
110 -- Read command line arguments
113 -- Prints out the option help
115 function Gmem_Initialize (Dumpname : String) return Boolean;
116 -- Opens the file represented by Dumpname and prepares it for
117 -- work. Returns False if the file does not have the correct format, True
120 procedure Gmem_A2l_Initialize (Exename : String);
121 -- Initialises the convert_addresses interface by supplying it with
122 -- the name of the executable file Exename
124 -----------------------------------
125 -- HTable address --> Allocation --
126 -----------------------------------
128 type Allocation is record
130 Size : Storage_Count;
133 type Address_Range is range 0 .. 4097;
134 function H (A : Integer_Address) return Address_Range;
135 No_Alloc : constant Allocation := (No_Root_Id, 0);
137 package Address_HTable is new GNAT.HTable.Simple_HTable (
138 Header_Num => Address_Range,
139 Element => Allocation,
140 No_Element => No_Alloc,
141 Key => Integer_Address,
145 BT_Depth : Integer := 1;
147 -- Some global statistics
149 Global_Alloc_Size : Storage_Count := 0;
150 -- Total number of bytes allocated during the lifetime of a program
152 Global_High_Water_Mark : Storage_Count := 0;
153 -- Largest amount of storage ever in use during the lifetime
155 Global_Nb_Alloc : Integer := 0;
156 -- Total number of allocations
158 Global_Nb_Dealloc : Integer := 0;
159 -- Total number of deallocations
161 Nb_Root : Integer := 0;
162 -- Total number of allocation roots
164 Nb_Wrong_Deall : Integer := 0;
165 -- Total number of wrong deallocations (i.e. without matching alloc)
167 Minimum_Nb_Leaks : Integer := 1;
168 -- How many unfreed allocs should be in a root for it to count as leak
170 T0 : Duration := 0.0;
171 -- The moment at which memory allocation routines initialized (should
172 -- be pretty close to the moment the program started since there are
173 -- always some allocations at RTL elaboration
175 Tmp_Alloc : Allocation;
176 Dump_Log_Mode : Boolean := False;
177 Quiet_Mode : Boolean := False;
179 ------------------------------
180 -- Allocation Roots Sorting --
181 ------------------------------
183 Sort_Order : String (1 .. 3) := "nwh";
184 -- This is the default order in which sorting criteria will be applied
185 -- n - Total number of unfreed allocations
186 -- w - Final watermark
187 -- h - High watermark
189 --------------------------------
190 -- GMEM functionality binding --
191 --------------------------------
193 ---------------------
194 -- Gmem_Initialize --
195 ---------------------
197 function Gmem_Initialize (Dumpname : String) return Boolean is
198 function Initialize (Dumpname : System.Address) return Duration;
199 pragma Import (C, Initialize, "__gnat_gmem_initialize");
201 S : aliased String := Dumpname & ASCII.NUL;
204 T0 := Initialize (S'Address);
208 -------------------------
209 -- Gmem_A2l_Initialize --
210 -------------------------
212 procedure Gmem_A2l_Initialize (Exename : String) is
213 procedure A2l_Initialize (Exename : System.Address);
214 pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
216 S : aliased String := Exename & ASCII.NUL;
219 A2l_Initialize (S'Address);
220 end Gmem_A2l_Initialize;
226 function Read_Next return Storage_Elmt is
227 procedure Read_Next (buf : System.Address);
228 pragma Import (C, Read_Next, "__gnat_gmem_read_next");
233 Read_Next (S'Address);
241 function H (A : Integer_Address) return Address_Range is
243 return Address_Range (A mod Integer_Address (Address_Range'Last));
250 function Mem_Image (X : Storage_Count) return String is
251 Ks : constant Storage_Count := X / 1024;
252 Megs : constant Storage_Count := Ks / 1024;
253 Buff : String (1 .. 7);
257 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
258 return Buff & " Megabytes";
261 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
262 return Buff & " Kilobytes";
265 Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
266 return Buff (1 .. 4) & " Bytes";
278 Put_Line (Gnat_Version_String);
279 Put_Line ("Copyright 1997-2007, Free Software Foundation, Inc.");
282 Put_Line ("Usage: gnatmem switches [depth] exename");
284 Put_Line (" depth backtrace depth to take into account, default is"
285 & Integer'Image (BT_Depth));
286 Put_Line (" exename the name of the executable to be analyzed");
288 Put_Line ("Switches:");
289 Put_Line (" -b n same as depth parameter");
290 Put_Line (" -i file read the allocation log from specific file");
291 Put_Line (" default is gmem.out in the current directory");
292 Put_Line (" -m n masks roots with less than n leaks, default is 1");
293 Put_Line (" specify 0 to see even released allocation roots");
294 Put_Line (" -q quiet, minimum output");
295 Put_Line (" -s order sort allocation roots according to an order of");
296 Put_Line (" sort criteria");
297 GNAT.OS_Lib.OS_Exit (1);
300 -----------------------
301 -- Process_Arguments --
302 -----------------------
304 procedure Process_Arguments is
306 -- Parse the options first
309 case Getopt ("b: dd m: i: q s:") is
310 when ASCII.NUL => exit;
314 BT_Depth := Natural'Value (Parameter);
316 when Constraint_Error =>
321 Dump_Log_Mode := True;
325 Minimum_Nb_Leaks := Natural'Value (Parameter);
327 when Constraint_Error =>
332 Log_Name := new String'(Parameter);
339 S : constant String (Sort_Order'Range) := Parameter;
341 for J in Sort_Order'Range loop
342 if S (J) = 'n' or else
346 Sort_Order (J) := S (J);
348 Put_Line ("Invalid sort criteria string.");
349 GNAT.OS_Lib.OS_Exit (1);
359 -- Set default log file if -i hasn't been specified
361 if Log_Name = null then
362 Log_Name := new String'("gmem.out");
365 -- Get the optional backtrace length and program name
368 Str1 : constant String := GNAT.Command_Line.Get_Argument;
369 Str2 : constant String := GNAT.Command_Line.Get_Argument;
377 Program_Name := new String'(Str1);
379 BT_Depth := Natural'Value (Str1);
380 Program_Name := new String'(Str2);
384 when Constraint_Error =>
388 -- Ensure presence of executable suffix in Program_Name
391 Suffix : String_Access := Get_Executable_Suffix;
398 (Program_Name.all'Last - Suffix.all'Length + 1 ..
399 Program_Name.all'Last) /= Suffix.all
401 Tmp := new String'(Program_Name.all & Suffix.all);
408 -- Search the executable on the path. If not found in the PATH, we
409 -- default to the current directory. Otherwise, libaddr2line will
410 -- fail with an error:
412 -- (null): Bad address
414 Tmp := Locate_Exec_On_Path (Program_Name.all);
417 Tmp := new String'('.' & Directory_Separator & Program_Name.all);
424 if not Is_Regular_File (Log_Name.all) then
425 Put_Line ("Couldn't find " & Log_Name.all);
426 GNAT.OS_Lib.OS_Exit (1);
429 if not Gmem_Initialize (Log_Name.all) then
430 Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
431 GNAT.OS_Lib.OS_Exit (1);
434 if not Is_Regular_File (Program_Name.all) then
435 Put_Line ("Couldn't find " & Program_Name.all);
438 Gmem_A2l_Initialize (Program_Name.all);
441 when GNAT.Command_Line.Invalid_Switch =>
442 Ada.Text_IO.Put_Line ("Invalid switch : "
443 & GNAT.Command_Line.Full_Switch);
445 end Process_Arguments;
449 Cur_Elmt : Storage_Elmt;
450 Buff : String (1 .. 16);
452 -- Start of processing for Gnatmem
457 if Dump_Log_Mode then
458 Put_Line ("Full dump of dynamic memory operations history");
459 Put_Line ("----------------------------------------------");
462 function CTime (Clock : Address) return Address;
463 pragma Import (C, CTime, "ctime");
465 Int_T0 : Integer := Integer (T0);
466 CTime_Addr : constant Address := CTime (Int_T0'Address);
468 Buffer : String (1 .. 30);
469 for Buffer'Address use CTime_Addr;
472 Put_Line ("Log started at T0 =" & Duration'Image (T0) & " ("
473 & Buffer (1 .. 24) & ")");
477 -- Main loop analysing the data generated by the instrumented routines.
478 -- For each allocation, the backtrace is kept and stored in a htable
479 -- whose entry is the address. For each deallocation, we look for the
480 -- corresponding allocation and cancel it.
483 Cur_Elmt := Read_Next;
485 case Cur_Elmt.Elmt is
491 -- Read the corresponding back trace
493 Tmp_Alloc.Root := Read_BT (BT_Depth);
497 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
498 Nb_Root := Nb_Root + 1;
501 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
502 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
504 elsif Cur_Elmt.Size > 0 then
506 -- Update global counters if the allocated size is meaningful
508 Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
509 Global_Nb_Alloc := Global_Nb_Alloc + 1;
511 if Global_High_Water_Mark < Global_Alloc_Size then
512 Global_High_Water_Mark := Global_Alloc_Size;
515 -- Update the number of allocation root if this is a new one
517 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
518 Nb_Root := Nb_Root + 1;
521 -- Update allocation root specific counters
523 Set_Alloc_Size (Tmp_Alloc.Root,
524 Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
526 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
528 if High_Water_Mark (Tmp_Alloc.Root) <
529 Alloc_Size (Tmp_Alloc.Root)
531 Set_High_Water_Mark (Tmp_Alloc.Root,
532 Alloc_Size (Tmp_Alloc.Root));
535 -- Associate this allocation root to the allocated address
537 Tmp_Alloc.Size := Cur_Elmt.Size;
538 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
544 -- Get the corresponding Dealloc_Size and Root
546 Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
548 if Tmp_Alloc.Root = No_Root_Id then
550 -- There was no prior allocation at this address, something is
551 -- very wrong. Mark this allocation root as problematic.
553 Tmp_Alloc.Root := Read_BT (BT_Depth);
555 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
556 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
557 Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
561 -- Update global counters
563 if not Quiet_Mode then
564 Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
567 Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
569 -- Update allocation root specific counters
571 if not Quiet_Mode then
572 Set_Alloc_Size (Tmp_Alloc.Root,
573 Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
576 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
578 -- Update the number of allocation root if this one disappears
580 if Nb_Alloc (Tmp_Alloc.Root) = 0
581 and then Minimum_Nb_Leaks > 0 then
582 Nb_Root := Nb_Root - 1;
585 -- Deassociate the deallocated address
587 Address_HTable.Remove (Cur_Elmt.Address);
594 if Dump_Log_Mode then
595 case Cur_Elmt.Elmt is
598 Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
600 Int_IO.Put (Buff (1 .. 8), Integer (Cur_Elmt.Size));
601 Put (Buff (1 .. 8) & " bytes at moment T0 +");
602 Put_Line (Duration'Image (Cur_Elmt.Timestamp - T0));
606 Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
608 Put_Line (" at moment T0 +"
609 & Duration'Image (Cur_Elmt.Timestamp - T0));
614 Print_BT (Tmp_Alloc.Root);
619 -- Print out general information about overall allocation
621 if not Quiet_Mode then
622 Put_Line ("Global information");
623 Put_Line ("------------------");
625 Put (" Total number of allocations :");
626 Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
629 Put (" Total number of deallocations :");
630 Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
633 Put_Line (" Final Water Mark (non freed mem) :"
634 & Mem_Image (Global_Alloc_Size));
635 Put_Line (" High Water Mark :"
636 & Mem_Image (Global_High_Water_Mark));
640 -- Print out the back traces corresponding to potential leaks in order
641 -- greatest number of non-deallocated allocations.
643 Print_Back_Traces : declare
644 type Root_Array is array (Natural range <>) of Root_Id;
645 type Access_Root_Array is access Root_Array;
647 Leaks : constant Access_Root_Array :=
648 new Root_Array (0 .. Nb_Root);
649 Leak_Index : Natural := 0;
651 Bogus_Dealls : constant Access_Root_Array :=
652 new Root_Array (1 .. Nb_Wrong_Deall);
653 Deall_Index : Natural := 0;
654 Nb_Alloc_J : Natural := 0;
656 procedure Move (From : Natural; To : Natural);
657 function Lt (Op1, Op2 : Natural) return Boolean;
658 package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
664 procedure Move (From : Natural; To : Natural) is
666 Leaks (To) := Leaks (From);
673 function Lt (Op1, Op2 : Natural) return Boolean is
675 function Apply_Sort_Criterion (S : Character) return Integer;
676 -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
677 -- smaller than, equal, or greater than Op2 according to criterion.
679 --------------------------
680 -- Apply_Sort_Criterion --
681 --------------------------
683 function Apply_Sort_Criterion (S : Character) return Integer is
684 LOp1, LOp2 : Integer;
689 LOp1 := Nb_Alloc (Leaks (Op1));
690 LOp2 := Nb_Alloc (Leaks (Op2));
693 LOp1 := Integer (Alloc_Size (Leaks (Op1)));
694 LOp2 := Integer (Alloc_Size (Leaks (Op2)));
697 LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
698 LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
701 return 0; -- Can't actually happen
706 elsif LOp1 > LOp2 then
713 when Constraint_Error =>
715 end Apply_Sort_Criterion;
721 -- Start of processing for Lt
724 for S in Sort_Order'Range loop
725 Result := Apply_Sort_Criterion (Sort_Order (S));
728 elsif Result = 1 then
735 -- Start of processing for Print_Back_Traces
738 -- Transfer all the relevant Roots in the Leaks and a Bogus_Deall arrays
740 Tmp_Alloc.Root := Get_First;
741 while Tmp_Alloc.Root /= No_Root_Id loop
742 if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_Nb_Leaks > 0 then
745 elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
746 Deall_Index := Deall_Index + 1;
747 Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
750 Leak_Index := Leak_Index + 1;
751 Leaks (Leak_Index) := Tmp_Alloc.Root;
754 Tmp_Alloc.Root := Get_Next;
757 -- Print out wrong deallocations
759 if Nb_Wrong_Deall > 0 then
760 Put_Line ("Releasing deallocated memory at :");
761 if not Quiet_Mode then
762 Put_Line ("--------------------------------");
765 for J in 1 .. Bogus_Dealls'Last loop
766 Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
771 -- Print out all allocation Leaks
773 if Leak_Index > 0 then
775 -- Sort the Leaks so that potentially important leaks appear first
777 Root_Sort.Sort (Leak_Index);
779 for J in 1 .. Leak_Index loop
780 Nb_Alloc_J := Nb_Alloc (Leaks (J));
782 if Nb_Alloc_J >= Minimum_Nb_Leaks then
784 if Nb_Alloc_J = 1 then
785 Put_Line (" 1 leak at :");
787 Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
791 Put_Line ("Allocation Root #" & Integer'Image (J));
792 Put_Line ("-------------------");
794 Put (" Number of non freed allocations :");
795 Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
799 (" Final Water Mark (non freed mem) :"
800 & Mem_Image (Alloc_Size (Leaks (J))));
803 (" High Water Mark :"
804 & Mem_Image (High_Water_Mark (Leaks (J))));
806 Put_Line (" Backtrace :");
809 Print_BT (Leaks (J), Short => Quiet_Mode);
814 end Print_Back_Traces;