1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2004, 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 Gnatvsn; use Gnatvsn;
59 with Ada.Text_IO; use Ada.Text_IO;
60 with Ada.Float_Text_IO;
61 with Ada.Integer_Text_IO;
63 with GNAT.Command_Line; use GNAT.Command_Line;
64 with GNAT.Heap_Sort_G;
65 with GNAT.OS_Lib; use GNAT.OS_Lib;
66 with GNAT.HTable; use GNAT.HTable;
68 with System; use System;
69 with System.Storage_Elements; use System.Storage_Elements;
71 with Memroot; use Memroot;
75 ------------------------
76 -- Other Declarations --
77 ------------------------
79 type Storage_Elmt is record
81 -- * = End of log file
82 -- A = found a ALLOC mark in the log
83 -- D = found a DEALL mark in the log
84 Address : Integer_Address;
87 -- This needs a comment ???
89 Log_Name, Program_Name : String_Access;
90 -- These need comments, and should be on separate lines ???
92 function Read_Next return Storage_Elmt;
93 -- Reads next dynamic storage operation from the log file.
95 function Mem_Image (X : Storage_Count) return String;
96 -- X is a size in storage_element. Returns a value
97 -- in Megabytes, Kilobytes or Bytes as appropriate.
99 procedure Process_Arguments;
100 -- Read command line arguments
103 -- Prints out the option help
105 function Gmem_Initialize (Dumpname : String) return Boolean;
106 -- Opens the file represented by Dumpname and prepares it for
107 -- work. Returns False if the file does not have the correct format, True
110 procedure Gmem_A2l_Initialize (Exename : String);
111 -- Initialises the convert_addresses interface by supplying it with
112 -- the name of the executable file Exename
114 -----------------------------------
115 -- HTable address --> Allocation --
116 -----------------------------------
118 type Allocation is record
120 Size : Storage_Count;
123 type Address_Range is range 0 .. 4097;
124 function H (A : Integer_Address) return Address_Range;
125 No_Alloc : constant Allocation := (No_Root_Id, 0);
127 package Address_HTable is new GNAT.HTable.Simple_HTable (
128 Header_Num => Address_Range,
129 Element => Allocation,
130 No_Element => No_Alloc,
131 Key => Integer_Address,
135 BT_Depth : Integer := 1;
137 -- The following need comments ???
139 Global_Alloc_Size : Storage_Count := 0;
140 Global_High_Water_Mark : Storage_Count := 0;
141 Global_Nb_Alloc : Integer := 0;
142 Global_Nb_Dealloc : Integer := 0;
143 Nb_Root : Integer := 0;
144 Nb_Wrong_Deall : Integer := 0;
145 Minimum_NB_Leaks : Integer := 1;
147 Tmp_Alloc : Allocation;
148 Quiet_Mode : Boolean := False;
150 ------------------------------
151 -- Allocation Roots Sorting --
152 ------------------------------
154 Sort_Order : String (1 .. 3) := "nwh";
155 -- This is the default order in which sorting criteria will be applied
156 -- n - Total number of unfreed allocations
157 -- w - Final watermark
158 -- h - High watermark
160 --------------------------------
161 -- GMEM functionality binding --
162 --------------------------------
164 function Gmem_Initialize (Dumpname : String) return Boolean is
165 function Initialize (Dumpname : System.Address) return Boolean;
166 pragma Import (C, Initialize, "__gnat_gmem_initialize");
168 S : aliased String := Dumpname & ASCII.NUL;
171 return Initialize (S'Address);
174 procedure Gmem_A2l_Initialize (Exename : String) is
175 procedure A2l_Initialize (Exename : System.Address);
176 pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
178 S : aliased String := Exename & ASCII.NUL;
181 A2l_Initialize (S'Address);
182 end Gmem_A2l_Initialize;
184 function Read_Next return Storage_Elmt is
185 procedure Read_Next (buf : System.Address);
186 pragma Import (C, Read_Next, "__gnat_gmem_read_next");
191 Read_Next (S'Address);
199 function H (A : Integer_Address) return Address_Range is
201 return Address_Range (A mod Integer_Address (Address_Range'Last));
208 function Mem_Image (X : Storage_Count) return String is
209 Ks : constant Storage_Count := X / 1024;
210 Megs : constant Storage_Count := Ks / 1024;
211 Buff : String (1 .. 7);
215 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
216 return Buff & " Megabytes";
219 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
220 return Buff & " Kilobytes";
223 Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
224 return Buff (1 .. 4) & " Bytes";
236 Put (Gnat_Version_String);
237 Put_Line (" Copyright 1997-2004 Free Software Foundation, Inc.");
240 Put_Line ("Usage: gnatmem switches [depth] exename");
242 Put_Line (" depth backtrace depth to take into account, default is"
243 & Integer'Image (BT_Depth));
244 Put_Line (" exename the name of the executable to be analyzed");
246 Put_Line ("Switches:");
247 Put_Line (" -b n same as depth parameter");
248 Put_Line (" -i file read the allocation log from specific file");
249 Put_Line (" default is gmem.out in the current directory");
250 Put_Line (" -m n masks roots with less than n leaks, default is 1");
251 Put_Line (" specify 0 to see even released allocation roots");
252 Put_Line (" -q quiet, minimum output");
253 Put_Line (" -s order sort allocation roots according to an order of");
254 Put_Line (" sort criteria");
255 GNAT.OS_Lib.OS_Exit (1);
258 -----------------------
259 -- Process_Arguments --
260 -----------------------
262 procedure Process_Arguments is
264 -- Parse the options first
267 case Getopt ("b: m: i: q s:") is
268 when ASCII.Nul => exit;
272 BT_Depth := Natural'Value (Parameter);
274 when Constraint_Error =>
280 Minimum_NB_Leaks := Natural'Value (Parameter);
282 when Constraint_Error =>
287 Log_Name := new String'(Parameter);
294 S : constant String (Sort_Order'Range) := Parameter;
297 for J in Sort_Order'Range loop
298 if S (J) = 'n' or else
302 Sort_Order (J) := S (J);
304 Put_Line ("Invalid sort criteria string.");
305 GNAT.OS_Lib.OS_Exit (1);
315 -- Set default log file if -i hasn't been specified
317 if Log_Name = null then
318 Log_Name := new String'("gmem.out");
321 -- Get the optional backtrace length and program name
324 Str1 : constant String := GNAT.Command_Line.Get_Argument;
325 Str2 : constant String := GNAT.Command_Line.Get_Argument;
333 Program_Name := new String'(Str1);
335 BT_Depth := Natural'Value (Str1);
336 Program_Name := new String'(Str2);
340 when Constraint_Error =>
344 -- Ensure presence of executable suffix in Program_Name
347 Suffix : String_Access := Get_Executable_Suffix;
354 (Program_Name.all'Last - Suffix.all'Length + 1 ..
355 Program_Name.all'Last) /= Suffix.all
357 Tmp := new String'(Program_Name.all & Suffix.all);
364 -- Search the executable on the path. If not found in the PATH, we
365 -- default to the current directory. Otherwise, libaddr2line will
366 -- fail with an error:
368 -- (null): Bad address
370 Tmp := Locate_Exec_On_Path (Program_Name.all);
373 Tmp := new String'('.' & Directory_Separator & Program_Name.all);
380 if not Is_Regular_File (Log_Name.all) then
381 Put_Line ("Couldn't find " & Log_Name.all);
382 GNAT.OS_Lib.OS_Exit (1);
385 if not Gmem_Initialize (Log_Name.all) then
386 Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
387 GNAT.OS_Lib.OS_Exit (1);
390 if not Is_Regular_File (Program_Name.all) then
391 Put_Line ("Couldn't find " & Program_Name.all);
394 Gmem_A2l_Initialize (Program_Name.all);
397 when GNAT.Command_Line.Invalid_Switch =>
398 Ada.Text_IO.Put_Line ("Invalid switch : "
399 & GNAT.Command_Line.Full_Switch);
401 end Process_Arguments;
403 Cur_Elmt : Storage_Elmt;
405 -- Start of processing for Gnatmem
410 -- Main loop analysing the data generated by the instrumented routines.
411 -- For each allocation, the backtrace is kept and stored in a htable
412 -- whose entry is the address. For each deallocation, we look for the
413 -- corresponding allocation and cancel it.
416 Cur_Elmt := Read_Next;
418 case Cur_Elmt.Elmt is
424 -- Update global counters if the allocated size is meaningful
427 Tmp_Alloc.Root := Read_BT (BT_Depth);
429 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
430 Nb_Root := Nb_Root + 1;
433 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
434 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
436 elsif Cur_Elmt.Size > 0 then
438 Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
439 Global_Nb_Alloc := Global_Nb_Alloc + 1;
441 if Global_High_Water_Mark < Global_Alloc_Size then
442 Global_High_Water_Mark := Global_Alloc_Size;
445 -- Read the corresponding back trace
447 Tmp_Alloc.Root := Read_BT (BT_Depth);
449 -- Update the number of allocation root if this is a new one
451 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
452 Nb_Root := Nb_Root + 1;
455 -- Update allocation root specific counters
457 Set_Alloc_Size (Tmp_Alloc.Root,
458 Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
460 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
462 if High_Water_Mark (Tmp_Alloc.Root) <
463 Alloc_Size (Tmp_Alloc.Root)
465 Set_High_Water_Mark (Tmp_Alloc.Root,
466 Alloc_Size (Tmp_Alloc.Root));
469 -- Associate this allocation root to the allocated address
471 Tmp_Alloc.Size := Cur_Elmt.Size;
472 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
474 -- non meaningful output, just consumes the backtrace
477 Tmp_Alloc.Root := Read_BT (BT_Depth);
482 -- Get the corresponding Dealloc_Size and Root
484 Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
486 if Tmp_Alloc.Root = No_Root_Id then
488 -- There was no prior allocation at this address, something is
489 -- very wrong. Mark this allocation root as problematic
491 Tmp_Alloc.Root := Read_BT (BT_Depth);
493 if Nb_Alloc (Tmp_Alloc.Root) = 0 then
494 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
495 Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
499 -- Update global counters
501 if not Quiet_Mode then
502 Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
505 Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
507 -- Update allocation root specific counters
509 if not Quiet_Mode then
510 Set_Alloc_Size (Tmp_Alloc.Root,
511 Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
514 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
516 -- update the number of allocation root if this one disappear
518 if Nb_Alloc (Tmp_Alloc.Root) = 0
519 and then Minimum_NB_Leaks > 0 then
520 Nb_Root := Nb_Root - 1;
523 -- De-associate the deallocated address
525 Address_HTable.Remove (Cur_Elmt.Address);
533 -- Print out general information about overall allocation
535 if not Quiet_Mode then
536 Put_Line ("Global information");
537 Put_Line ("------------------");
539 Put (" Total number of allocations :");
540 Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
543 Put (" Total number of deallocations :");
544 Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
547 Put_Line (" Final Water Mark (non freed mem) :"
548 & Mem_Image (Global_Alloc_Size));
549 Put_Line (" High Water Mark :"
550 & Mem_Image (Global_High_Water_Mark));
554 -- Print out the back traces corresponding to potential leaks in order
555 -- greatest number of non-deallocated allocations
557 Print_Back_Traces : declare
558 type Root_Array is array (Natural range <>) of Root_Id;
559 Leaks : Root_Array (0 .. Nb_Root);
560 Leak_Index : Natural := 0;
562 Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
563 Deall_Index : Natural := 0;
564 Nb_Alloc_J : Natural := 0;
566 procedure Move (From : Natural; To : Natural);
567 function Lt (Op1, Op2 : Natural) return Boolean;
568 package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
570 procedure Move (From : Natural; To : Natural) is
572 Leaks (To) := Leaks (From);
575 function Lt (Op1, Op2 : Natural) return Boolean is
576 function Apply_Sort_Criterion (S : Character) return Integer;
577 -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
578 -- smaller than, equal, or greater than Op2 according to criterion
580 function Apply_Sort_Criterion (S : Character) return Integer is
581 LOp1, LOp2 : Integer;
585 LOp1 := Nb_Alloc (Leaks (Op1));
586 LOp2 := Nb_Alloc (Leaks (Op2));
589 LOp1 := Integer (Alloc_Size (Leaks (Op1)));
590 LOp2 := Integer (Alloc_Size (Leaks (Op2)));
593 LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
594 LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
597 return 0; -- Can't actually happen
602 elsif LOp1 > LOp2 then
608 when Constraint_Error =>
610 end Apply_Sort_Criterion;
614 -- Start of processing for Lt
617 for S in Sort_Order'Range loop
618 Result := Apply_Sort_Criterion (Sort_Order (S));
621 elsif Result = 1 then
628 -- Start of processing for Print_Back_Traces
631 -- Transfer all the relevant Roots in the Leaks and a
632 -- Bogus_Deall arrays
634 Tmp_Alloc.Root := Get_First;
635 while Tmp_Alloc.Root /= No_Root_Id loop
636 if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 0 then
639 elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
640 Deall_Index := Deall_Index + 1;
641 Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
644 Leak_Index := Leak_Index + 1;
645 Leaks (Leak_Index) := Tmp_Alloc.Root;
648 Tmp_Alloc.Root := Get_Next;
651 -- Print out wrong deallocations
653 if Nb_Wrong_Deall > 0 then
654 Put_Line ("Releasing deallocated memory at :");
655 if not Quiet_Mode then
656 Put_Line ("--------------------------------");
659 for J in 1 .. Bogus_Dealls'Last loop
660 Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
665 -- Print out all allocation Leaks
669 -- Sort the Leaks so that potentially important leaks appear first
671 Root_Sort.Sort (Nb_Root);
673 for J in 1 .. Leaks'Last loop
674 Nb_Alloc_J := Nb_Alloc (Leaks (J));
675 if Nb_Alloc_J >= Minimum_NB_Leaks then
677 if Nb_Alloc_J = 1 then
678 Put_Line (" 1 leak at :");
680 Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
684 Put_Line ("Allocation Root #" & Integer'Image (J));
685 Put_Line ("-------------------");
687 Put (" Number of non freed allocations :");
688 Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
692 (" Final Water Mark (non freed mem) :"
693 & Mem_Image (Alloc_Size (Leaks (J))));
696 (" High Water Mark :"
697 & Mem_Image (High_Water_Mark (Leaks (J))));
699 Put_Line (" Backtrace :");
702 Print_BT (Leaks (J), Short => Quiet_Mode);
707 end Print_Back_Traces;