1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2005, 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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Gnatvsn; use Gnatvsn;
58 with Ada.Text_IO; use Ada.Text_IO;
59 with Ada.Float_Text_IO;
60 with Ada.Integer_Text_IO;
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 System; use System;
68 with System.Storage_Elements; use System.Storage_Elements;
70 with Memroot; use Memroot;
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
83 Address : Integer_Address;
86 -- This needs a comment ???
88 Log_Name, Program_Name : String_Access;
89 -- These need comments, and should be on separate lines ???
91 function Read_Next return Storage_Elmt;
92 -- Reads next dynamic storage operation from the log file
94 function Mem_Image (X : Storage_Count) return String;
95 -- X is a size in storage_element. Returns a value
96 -- in Megabytes, Kilobytes or Bytes as appropriate.
98 procedure Process_Arguments;
99 -- Read command line arguments
102 -- Prints out the option help
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
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
113 -----------------------------------
114 -- HTable address --> Allocation --
115 -----------------------------------
117 type Allocation is record
119 Size : Storage_Count;
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);
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,
134 BT_Depth : Integer := 1;
136 -- The following need comments ???
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;
144 Minimum_NB_Leaks : Integer := 1;
146 Tmp_Alloc : Allocation;
147 Quiet_Mode : Boolean := False;
149 ------------------------------
150 -- Allocation Roots Sorting --
151 ------------------------------
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
159 --------------------------------
160 -- GMEM functionality binding --
161 --------------------------------
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");
167 S : aliased String := Dumpname & ASCII.NUL;
170 return Initialize (S'Address);
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");
177 S : aliased String := Exename & ASCII.NUL;
180 A2l_Initialize (S'Address);
181 end Gmem_A2l_Initialize;
183 function Read_Next return Storage_Elmt is
184 procedure Read_Next (buf : System.Address);
185 pragma Import (C, Read_Next, "__gnat_gmem_read_next");
190 Read_Next (S'Address);
198 function H (A : Integer_Address) return Address_Range is
200 return Address_Range (A mod Integer_Address (Address_Range'Last));
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);
214 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
215 return Buff & " Megabytes";
218 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
219 return Buff & " Kilobytes";
222 Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
223 return Buff (1 .. 4) & " Bytes";
235 Put_Line (Gnat_Version_String);
236 Put_Line ("Copyright 1997-2005, Free Software Foundation, Inc.");
239 Put_Line ("Usage: gnatmem switches [depth] exename");
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");
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");
251 Put_Line (" -q quiet, minimum output");
252 Put_Line (" -s order sort allocation roots according to an order of");
253 Put_Line (" sort criteria");
254 GNAT.OS_Lib.OS_Exit (1);
257 -----------------------
258 -- Process_Arguments --
259 -----------------------
261 procedure Process_Arguments is
263 -- Parse the options first
266 case Getopt ("b: m: i: q s:") is
267 when ASCII.Nul => exit;
271 BT_Depth := Natural'Value (Parameter);
273 when Constraint_Error =>
279 Minimum_NB_Leaks := Natural'Value (Parameter);
281 when Constraint_Error =>
286 Log_Name := new String'(Parameter);
293 S : constant String (Sort_Order'Range) := Parameter;
296 for J in Sort_Order'Range loop
297 if S (J) = 'n' or else
301 Sort_Order (J) := S (J);
303 Put_Line ("Invalid sort criteria string.");
304 GNAT.OS_Lib.OS_Exit (1);
314 -- Set default log file if -i hasn't been specified
316 if Log_Name = null then
317 Log_Name := new String'("gmem.out");
320 -- Get the optional backtrace length and program name
323 Str1 : constant String := GNAT.Command_Line.Get_Argument;
324 Str2 : constant String := GNAT.Command_Line.Get_Argument;
332 Program_Name := new String'(Str1);
334 BT_Depth := Natural'Value (Str1);
335 Program_Name := new String'(Str2);
339 when Constraint_Error =>
343 -- Ensure presence of executable suffix in Program_Name
346 Suffix : String_Access := Get_Executable_Suffix;
353 (Program_Name.all'Last - Suffix.all'Length + 1 ..
354 Program_Name.all'Last) /= Suffix.all
356 Tmp := new String'(Program_Name.all & Suffix.all);
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:
367 -- (null): Bad address
369 Tmp := Locate_Exec_On_Path (Program_Name.all);
372 Tmp := new String'('.' & Directory_Separator & Program_Name.all);
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);
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);
389 if not Is_Regular_File (Program_Name.all) then
390 Put_Line ("Couldn't find " & Program_Name.all);
393 Gmem_A2l_Initialize (Program_Name.all);
396 when GNAT.Command_Line.Invalid_Switch =>
397 Ada.Text_IO.Put_Line ("Invalid switch : "
398 & GNAT.Command_Line.Full_Switch);
400 end Process_Arguments;
402 Cur_Elmt : Storage_Elmt;
404 -- Start of processing for Gnatmem
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
412 -- corresponding allocation and cancel it.
415 Cur_Elmt := Read_Next;
417 case Cur_Elmt.Elmt is
423 -- Update global counters if the allocated size is meaningful
426 Tmp_Alloc.Root := Read_BT (BT_Depth);
428 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
429 Nb_Root := Nb_Root + 1;
432 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
433 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
435 elsif Cur_Elmt.Size > 0 then
437 Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
438 Global_Nb_Alloc := Global_Nb_Alloc + 1;
440 if Global_High_Water_Mark < Global_Alloc_Size then
441 Global_High_Water_Mark := Global_Alloc_Size;
444 -- Read the corresponding back trace
446 Tmp_Alloc.Root := Read_BT (BT_Depth);
448 -- Update the number of allocation root if this is a new one
450 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
451 Nb_Root := Nb_Root + 1;
454 -- Update allocation root specific counters
456 Set_Alloc_Size (Tmp_Alloc.Root,
457 Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
459 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
461 if High_Water_Mark (Tmp_Alloc.Root) <
462 Alloc_Size (Tmp_Alloc.Root)
464 Set_High_Water_Mark (Tmp_Alloc.Root,
465 Alloc_Size (Tmp_Alloc.Root));
468 -- Associate this allocation root to the allocated address
470 Tmp_Alloc.Size := Cur_Elmt.Size;
471 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
473 -- non meaningful output, just consumes the backtrace
476 Tmp_Alloc.Root := Read_BT (BT_Depth);
481 -- Get the corresponding Dealloc_Size and Root
483 Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
485 if Tmp_Alloc.Root = No_Root_Id then
487 -- There was no prior allocation at this address, something is
488 -- very wrong. Mark this allocation root as problematic
490 Tmp_Alloc.Root := Read_BT (BT_Depth);
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;
498 -- Update global counters
500 if not Quiet_Mode then
501 Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
504 Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
506 -- Update allocation root specific counters
508 if not Quiet_Mode then
509 Set_Alloc_Size (Tmp_Alloc.Root,
510 Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
513 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
515 -- update the number of allocation root if this one disappear
517 if Nb_Alloc (Tmp_Alloc.Root) = 0
518 and then Minimum_NB_Leaks > 0 then
519 Nb_Root := Nb_Root - 1;
522 -- De-associate the deallocated address
524 Address_HTable.Remove (Cur_Elmt.Address);
532 -- Print out general information about overall allocation
534 if not Quiet_Mode then
535 Put_Line ("Global information");
536 Put_Line ("------------------");
538 Put (" Total number of allocations :");
539 Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
542 Put (" Total number of deallocations :");
543 Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
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));
553 -- Print out the back traces corresponding to potential leaks in order
554 -- greatest number of non-deallocated allocations
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;
561 Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
562 Deall_Index : Natural := 0;
563 Nb_Alloc_J : Natural := 0;
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);
569 procedure Move (From : Natural; To : Natural) is
571 Leaks (To) := Leaks (From);
574 function Lt (Op1, Op2 : Natural) return Boolean is
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
579 function Apply_Sort_Criterion (S : Character) return Integer is
580 LOp1, LOp2 : Integer;
584 LOp1 := Nb_Alloc (Leaks (Op1));
585 LOp2 := Nb_Alloc (Leaks (Op2));
588 LOp1 := Integer (Alloc_Size (Leaks (Op1)));
589 LOp2 := Integer (Alloc_Size (Leaks (Op2)));
592 LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
593 LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
596 return 0; -- Can't actually happen
601 elsif LOp1 > LOp2 then
607 when Constraint_Error =>
609 end Apply_Sort_Criterion;
613 -- Start of processing for Lt
616 for S in Sort_Order'Range loop
617 Result := Apply_Sort_Criterion (Sort_Order (S));
620 elsif Result = 1 then
627 -- Start of processing for Print_Back_Traces
630 -- Transfer all the relevant Roots in the Leaks and a
631 -- Bogus_Deall arrays
633 Tmp_Alloc.Root := Get_First;
634 while Tmp_Alloc.Root /= No_Root_Id loop
635 if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 0 then
638 elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
639 Deall_Index := Deall_Index + 1;
640 Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
643 Leak_Index := Leak_Index + 1;
644 Leaks (Leak_Index) := Tmp_Alloc.Root;
647 Tmp_Alloc.Root := Get_Next;
650 -- Print out wrong deallocations
652 if Nb_Wrong_Deall > 0 then
653 Put_Line ("Releasing deallocated memory at :");
654 if not Quiet_Mode then
655 Put_Line ("--------------------------------");
658 for J in 1 .. Bogus_Dealls'Last loop
659 Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
664 -- Print out all allocation Leaks
668 -- Sort the Leaks so that potentially important leaks appear first
670 Root_Sort.Sort (Nb_Root);
672 for J in 1 .. Leaks'Last loop
673 Nb_Alloc_J := Nb_Alloc (Leaks (J));
674 if Nb_Alloc_J >= Minimum_NB_Leaks then
676 if Nb_Alloc_J = 1 then
677 Put_Line (" 1 leak at :");
679 Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
683 Put_Line ("Allocation Root #" & Integer'Image (J));
684 Put_Line ("-------------------");
686 Put (" Number of non freed allocations :");
687 Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
691 (" Final Water Mark (non freed mem) :"
692 & Mem_Image (Alloc_Size (Leaks (J))));
695 (" High Water Mark :"
696 & Mem_Image (High_Water_Mark (Leaks (J))));
698 Put_Line (" Backtrace :");
701 Print_BT (Leaks (J), Short => Quiet_Mode);
706 end Print_Back_Traces;