1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T M E M -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1997-2004, Ada Core Technologies, Inc. -- 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. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27-- GNATMEM is a utility that tracks memory leaks. It is based on a simple 28-- idea: 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 40-- - Record a reference to the allocated memory on each allocation call. 41 42-- - Suppress this reference on deallocation. 43 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 46-- the leak. 47 48-- This capability is not supported on all platforms, please refer to 49-- memtrack.adb for further information. 50 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.) 55 56with Gnatvsn; use Gnatvsn; 57 58 59with Ada.Text_IO; use Ada.Text_IO; 60with Ada.Float_Text_IO; 61with Ada.Integer_Text_IO; 62 63with GNAT.Command_Line; use GNAT.Command_Line; 64with GNAT.Heap_Sort_G; 65with GNAT.OS_Lib; use GNAT.OS_Lib; 66with GNAT.HTable; use GNAT.HTable; 67 68with System; use System; 69with System.Storage_Elements; use System.Storage_Elements; 70 71with Memroot; use Memroot; 72 73procedure Gnatmem is 74 75 ------------------------ 76 -- Other Declarations -- 77 ------------------------ 78 79 type Storage_Elmt is record 80 Elmt : Character; 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; 85 Size : Storage_Count; 86 end record; 87 -- This needs a comment ??? 88 89 Log_Name, Program_Name : String_Access; 90 -- These need comments, and should be on separate lines ??? 91 92 function Read_Next return Storage_Elmt; 93 -- Reads next dynamic storage operation from the log file. 94 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. 98 99 procedure Process_Arguments; 100 -- Read command line arguments 101 102 procedure Usage; 103 -- Prints out the option help 104 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 108 -- otherwise. 109 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 113 114 ----------------------------------- 115 -- HTable address --> Allocation -- 116 ----------------------------------- 117 118 type Allocation is record 119 Root : Root_Id; 120 Size : Storage_Count; 121 end record; 122 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); 126 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, 132 Hash => H, 133 Equal => "="); 134 135 BT_Depth : Integer := 1; 136 137 -- The following need comments ??? 138 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; 146 147 Tmp_Alloc : Allocation; 148 Quiet_Mode : Boolean := False; 149 150 ------------------------------- 151 -- Allocation roots sorting -- 152 ------------------------------- 153 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 159 160 -------------------------------- 161 -- GMEM functionality binding -- 162 -------------------------------- 163 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"); 167 168 S : aliased String := Dumpname & ASCII.NUL; 169 170 begin 171 return Initialize (S'Address); 172 end Gmem_Initialize; 173 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"); 177 178 S : aliased String := Exename & ASCII.NUL; 179 180 begin 181 A2l_Initialize (S'Address); 182 end Gmem_A2l_Initialize; 183 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"); 187 188 S : Storage_Elmt; 189 190 begin 191 Read_Next (S'Address); 192 return S; 193 end Read_Next; 194 195 ------- 196 -- H -- 197 ------- 198 199 function H (A : Integer_Address) return Address_Range is 200 begin 201 return Address_Range (A mod Integer_Address (Address_Range'Last)); 202 end H; 203 204 --------------- 205 -- Mem_Image -- 206 --------------- 207 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); 212 213 begin 214 if Megs /= 0 then 215 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0); 216 return Buff & " Megabytes"; 217 218 elsif Ks /= 0 then 219 Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0); 220 return Buff & " Kilobytes"; 221 222 else 223 Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X)); 224 return Buff (1 .. 4) & " Bytes"; 225 end if; 226 end Mem_Image; 227 228 ----------- 229 -- Usage -- 230 ----------- 231 232 procedure Usage is 233 begin 234 New_Line; 235 Put ("GNATMEM "); 236 Put (Gnat_Version_String); 237 Put_Line (" Copyright 1997-2004 Free Software Foundation, Inc."); 238 New_Line; 239 240 Put_Line ("Usage: gnatmem switches [depth] exename"); 241 New_Line; 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"); 245 New_Line; 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); 256 end Usage; 257 258 ----------------------- 259 -- Process_Arguments -- 260 ----------------------- 261 262 procedure Process_Arguments is 263 begin 264 -- Parse the options first 265 266 loop 267 case Getopt ("b: m: i: q s:") is 268 when ASCII.Nul => exit; 269 270 when 'b' => 271 begin 272 BT_Depth := Natural'Value (Parameter); 273 exception 274 when Constraint_Error => 275 Usage; 276 end; 277 278 when 'm' => 279 begin 280 Minimum_NB_Leaks := Natural'Value (Parameter); 281 exception 282 when Constraint_Error => 283 Usage; 284 end; 285 286 when 'i' => 287 Log_Name := new String'(Parameter); 288 289 when 'q' => 290 Quiet_Mode := True; 291 292 when 's' => 293 declare 294 S : constant String (Sort_Order'Range) := Parameter; 295 296 begin 297 for J in Sort_Order'Range loop 298 if S (J) = 'n' or else 299 S (J) = 'w' or else 300 S (J) = 'h' 301 then 302 Sort_Order (J) := S (J); 303 else 304 Put_Line ("Invalid sort criteria string."); 305 GNAT.OS_Lib.OS_Exit (1); 306 end if; 307 end loop; 308 end; 309 310 when others => 311 null; 312 end case; 313 end loop; 314 315 -- Set default log file if -i hasn't been specified 316 317 if Log_Name = null then 318 Log_Name := new String'("gmem.out"); 319 end if; 320 321 -- Get the optional backtrace length and program name 322 323 declare 324 Str1 : constant String := GNAT.Command_Line.Get_Argument; 325 Str2 : constant String := GNAT.Command_Line.Get_Argument; 326 327 begin 328 if Str1 = "" then 329 Usage; 330 end if; 331 332 if Str2 = "" then 333 Program_Name := new String'(Str1); 334 else 335 BT_Depth := Natural'Value (Str1); 336 Program_Name := new String'(Str2); 337 end if; 338 339 exception 340 when Constraint_Error => 341 Usage; 342 end; 343 344 -- Ensure presence of executable suffix in Program_Name 345 346 declare 347 Suffix : String_Access := Get_Executable_Suffix; 348 Tmp : String_Access; 349 350 begin 351 if Suffix.all /= "" 352 and then 353 Program_Name.all 354 (Program_Name.all'Last - Suffix.all'Length + 1 .. 355 Program_Name.all'Last) /= Suffix.all 356 then 357 Tmp := new String'(Program_Name.all & Suffix.all); 358 Free (Program_Name); 359 Program_Name := Tmp; 360 end if; 361 362 Free (Suffix); 363 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: 367 368 -- (null): Bad address 369 370 Tmp := Locate_Exec_On_Path (Program_Name.all); 371 372 if Tmp = null then 373 Tmp := new String'('.' & Directory_Separator & Program_Name.all); 374 end if; 375 376 Free (Program_Name); 377 Program_Name := Tmp; 378 end; 379 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); 383 end if; 384 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); 388 end if; 389 390 if not Is_Regular_File (Program_Name.all) then 391 Put_Line ("Couldn't find " & Program_Name.all); 392 end if; 393 394 Gmem_A2l_Initialize (Program_Name.all); 395 396 exception 397 when GNAT.Command_Line.Invalid_Switch => 398 Ada.Text_IO.Put_Line ("Invalid switch : " 399 & GNAT.Command_Line.Full_Switch); 400 Usage; 401 end Process_Arguments; 402 403 Cur_Elmt : Storage_Elmt; 404 405-- Start of processing for Gnatmem 406 407begin 408 Process_Arguments; 409 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. 414 415 Main : loop 416 Cur_Elmt := Read_Next; 417 418 case Cur_Elmt.Elmt is 419 when '*' => 420 exit Main; 421 422 when 'A' => 423 424 -- Update global counters if the allocated size is meaningful 425 426 if Quiet_Mode then 427 Tmp_Alloc.Root := Read_BT (BT_Depth); 428 429 if Nb_Alloc (Tmp_Alloc.Root) = 0 then 430 Nb_Root := Nb_Root + 1; 431 end if; 432 433 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); 434 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); 435 436 elsif Cur_Elmt.Size > 0 then 437 438 Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size; 439 Global_Nb_Alloc := Global_Nb_Alloc + 1; 440 441 if Global_High_Water_Mark < Global_Alloc_Size then 442 Global_High_Water_Mark := Global_Alloc_Size; 443 end if; 444 445 -- Read the corresponding back trace 446 447 Tmp_Alloc.Root := Read_BT (BT_Depth); 448 449 -- Update the number of allocation root if this is a new one 450 451 if Nb_Alloc (Tmp_Alloc.Root) = 0 then 452 Nb_Root := Nb_Root + 1; 453 end if; 454 455 -- Update allocation root specific counters 456 457 Set_Alloc_Size (Tmp_Alloc.Root, 458 Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size); 459 460 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1); 461 462 if High_Water_Mark (Tmp_Alloc.Root) < 463 Alloc_Size (Tmp_Alloc.Root) 464 then 465 Set_High_Water_Mark (Tmp_Alloc.Root, 466 Alloc_Size (Tmp_Alloc.Root)); 467 end if; 468 469 -- Associate this allocation root to the allocated address 470 471 Tmp_Alloc.Size := Cur_Elmt.Size; 472 Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc); 473 474 -- non meaningful output, just consumes the backtrace 475 476 else 477 Tmp_Alloc.Root := Read_BT (BT_Depth); 478 end if; 479 480 when 'D' => 481 482 -- Get the corresponding Dealloc_Size and Root 483 484 Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address); 485 486 if Tmp_Alloc.Root = No_Root_Id then 487 488 -- There was no prior allocation at this address, something is 489 -- very wrong. Mark this allocation root as problematic 490 491 Tmp_Alloc.Root := Read_BT (BT_Depth); 492 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; 496 end if; 497 498 else 499 -- Update global counters 500 501 if not Quiet_Mode then 502 Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size; 503 end if; 504 505 Global_Nb_Dealloc := Global_Nb_Dealloc + 1; 506 507 -- Update allocation root specific counters 508 509 if not Quiet_Mode then 510 Set_Alloc_Size (Tmp_Alloc.Root, 511 Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size); 512 end if; 513 514 Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1); 515 516 -- update the number of allocation root if this one disappear 517 518 if Nb_Alloc (Tmp_Alloc.Root) = 0 519 and then Minimum_NB_Leaks > 0 then 520 Nb_Root := Nb_Root - 1; 521 end if; 522 523 -- De-associate the deallocated address 524 525 Address_HTable.Remove (Cur_Elmt.Address); 526 end if; 527 528 when others => 529 raise Program_Error; 530 end case; 531 end loop Main; 532 533 -- Print out general information about overall allocation 534 535 if not Quiet_Mode then 536 Put_Line ("Global information"); 537 Put_Line ("------------------"); 538 539 Put (" Total number of allocations :"); 540 Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4); 541 New_Line; 542 543 Put (" Total number of deallocations :"); 544 Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4); 545 New_Line; 546 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)); 551 New_Line; 552 end if; 553 554 -- Print out the back traces corresponding to potential leaks in order 555 -- greatest number of non-deallocated allocations 556 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; 561 562 Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall); 563 Deall_Index : Natural := 0; 564 Nb_Alloc_J : Natural := 0; 565 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); 569 570 procedure Move (From : Natural; To : Natural) is 571 begin 572 Leaks (To) := Leaks (From); 573 end Move; 574 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 579 580 function Apply_Sort_Criterion (S : Character) return Integer is 581 LOp1, LOp2 : Integer; 582 begin 583 case S is 584 when 'n' => 585 LOp1 := Nb_Alloc (Leaks (Op1)); 586 LOp2 := Nb_Alloc (Leaks (Op2)); 587 588 when 'w' => 589 LOp1 := Integer (Alloc_Size (Leaks (Op1))); 590 LOp2 := Integer (Alloc_Size (Leaks (Op2))); 591 592 when 'h' => 593 LOp1 := Integer (High_Water_Mark (Leaks (Op1))); 594 LOp2 := Integer (High_Water_Mark (Leaks (Op2))); 595 596 when others => 597 return 0; -- Can't actually happen 598 end case; 599 600 if LOp1 < LOp2 then 601 return -1; 602 elsif LOp1 > LOp2 then 603 return 1; 604 else 605 return 0; 606 end if; 607 exception 608 when Constraint_Error => 609 return 0; 610 end Apply_Sort_Criterion; 611 612 Result : Integer; 613 614 -- Start of processing for Lt 615 616 begin 617 for S in Sort_Order'Range loop 618 Result := Apply_Sort_Criterion (Sort_Order (S)); 619 if Result = -1 then 620 return False; 621 elsif Result = 1 then 622 return True; 623 end if; 624 end loop; 625 return False; 626 end Lt; 627 628 -- Start of processing for Print_Back_Traces 629 630 begin 631 -- Transfer all the relevant Roots in the Leaks and a 632 -- Bogus_Deall arrays 633 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 637 null; 638 639 elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then 640 Deall_Index := Deall_Index + 1; 641 Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root; 642 643 else 644 Leak_Index := Leak_Index + 1; 645 Leaks (Leak_Index) := Tmp_Alloc.Root; 646 end if; 647 648 Tmp_Alloc.Root := Get_Next; 649 end loop; 650 651 -- Print out wrong deallocations 652 653 if Nb_Wrong_Deall > 0 then 654 Put_Line ("Releasing deallocated memory at :"); 655 if not Quiet_Mode then 656 Put_Line ("--------------------------------"); 657 end if; 658 659 for J in 1 .. Bogus_Dealls'Last loop 660 Print_BT (Bogus_Dealls (J), Short => Quiet_Mode); 661 New_Line; 662 end loop; 663 end if; 664 665 -- Print out all allocation Leaks 666 667 if Nb_Root > 0 then 668 669 -- Sort the Leaks so that potentially important leaks appear first 670 671 Root_Sort.Sort (Nb_Root); 672 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 676 if Quiet_Mode then 677 if Nb_Alloc_J = 1 then 678 Put_Line (" 1 leak at :"); 679 else 680 Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :"); 681 end if; 682 683 else 684 Put_Line ("Allocation Root #" & Integer'Image (J)); 685 Put_Line ("-------------------"); 686 687 Put (" Number of non freed allocations :"); 688 Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4); 689 New_Line; 690 691 Put_Line 692 (" Final Water Mark (non freed mem) :" 693 & Mem_Image (Alloc_Size (Leaks (J)))); 694 695 Put_Line 696 (" High Water Mark :" 697 & Mem_Image (High_Water_Mark (Leaks (J)))); 698 699 Put_Line (" Backtrace :"); 700 end if; 701 702 Print_BT (Leaks (J), Short => Quiet_Mode); 703 New_Line; 704 end if; 705 end loop; 706 end if; 707 end Print_Back_Traces; 708end Gnatmem; 709