gcc/ada/gnatmem.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              G N A T M E M                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --           Copyright (C) 1997-2002, Ada Core Technologies, Inc.           --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  GNATMEM is a utility that tracks memory leaks. It is based on a simple
  29 --  idea:
  30 --      - run the application under gdb
  31 --      - set a breakpoint on __gnat_malloc and __gnat_free
  32 --      - record a reference to the allocated memory on each allocation call
  33 --      - suppress this reference on deallocation
  34 --      - at the end of the program, remaining references are potential leaks.
  35 --        sort them out the best possible way in order to locate the root of
  36 --        the leak.
  37 --
  38 --   GNATMEM can also be used with instrumented allocation/deallocation
  39 --   routine (see a-raise.c with symbol GMEM defined). This is not supported
  40 --   in all platforms, again refer to a-raise.c for further information.
  41 --   In this case the application must be relinked with library libgmem.a:
  42 --
  43 --      $ gnatmake my_prog -largs -lgmem
  44 --
  45 --   The running my_prog will produce a file named gmem.out that will be
  46 --   parsed by gnatmem.
  47 --
  48 --   In order to help finding out the real leaks,  the notion of "allocation
  49 --   root" is defined. An allocation root is a specific point in the program
  50 --   execution generating memory allocation where data is collected (such as
  51 --   number of allocations, quantify of memory allocated, high water mark,
  52 --   etc.).
  53
  54 with Ada.Command_Line;        use Ada.Command_Line;
  55 with Ada.Text_IO;             use Ada.Text_IO;
  56 with Ada.Text_IO.C_Streams;
  57 with Ada.Float_Text_IO;
  58 with Ada.Integer_Text_IO;
  59 with Gnatvsn;                 use Gnatvsn;
  60 with GNAT.Heap_Sort_G;
  61 with GNAT.OS_Lib;
  62 with GNAT.HTable;             use GNAT.HTable;
  63 with Interfaces.C_Streams;    use Interfaces.C_Streams;
  64 with System;                  use System;
  65 with System.Storage_Elements; use System.Storage_Elements;
  66
  67 with Memroot; use Memroot;
  68
  69 procedure Gnatmem is
  70
  71    ------------------------------------------------
  72    --  Potentially Target Dependent Subprograms. --
  73    ------------------------------------------------
  74
  75    function Get_Current_TTY return String;
  76    --  Give the current tty on which the program is run. This is needed to
  77    --  separate the output of the debugger from the output of the program.
  78    --  The output of this function will be used to call the gdb command "tty"
  79    --  in the gdb script in order to get the program output on the current tty
  80    --  while the gdb output is redirected and processed by gnatmem.
  81
  82    function popen  (File, Mode : System.Address) return FILEs;
  83    pragma Import (C, popen, "popen");
  84    --  Execute the program 'File'. If the mode is "r" the standard output
  85    --  of the program is redirected and the FILEs handler of the
  86    --  redirection is returned.
  87
  88    procedure System_Cmd (X : System.Address);
  89    pragma Import (C, System_Cmd, "system");
  90    --  Execute the program "X".
  91
  92    subtype Cstring        is String (1 .. Integer'Last);
  93    type    Cstring_Ptr is access all Cstring;
  94
  95    function ttyname (Dec : Integer) return Cstring_Ptr;
  96    pragma Import (C, ttyname, "__gnat_ttyname");
  97    --  Return a null-terminated string containing the current tty
  98
  99    Dir_Sep : constant Character := '/';
 100
 101    ------------------------
 102    -- Other Declarations --
 103    ------------------------
 104
 105    type Gdb_Output_Elmt is (Eof, Alloc, Deall);
 106    --  Eof    = End of gdb output file
 107    --  Alloc  = found a ALLOC mark in the gdb output
 108    --  Deall  = found a DEALL mark in the gdb output
 109    Gdb_Output_Format_Error : exception;
 110
 111    function Read_Next return Gdb_Output_Elmt;
 112    --  Read the output of the debugger till it finds either the end of the
 113    --  output, or the 'ALLOC' mark or the 'DEALL' mark. In the second case,
 114    --  it sets the Tmp_Size and Tmp_Address global variables, in the
 115    --  third case it sets the Tmp_Address variable.
 116
 117    procedure Create_Gdb_Script;
 118    --  Create the GDB script and save it in a temporary file
 119
 120    function Mem_Image (X : Storage_Count) return String;
 121    --  X is a size in storage_element. Returns a value
 122    --  in Megabytes, Kiloytes or Bytes as appropriate.
 123
 124    procedure Process_Arguments;
 125    --  Read command line arguments;
 126
 127    procedure Usage;
 128    --  Prints out the option help
 129
 130    function Gmem_Initialize (Dumpname : String) return Boolean;
 131    --  Opens the file represented by Dumpname and prepares it for
 132    --  work. Returns False if the file does not have the correct format, True
 133    --  otherwise.
 134
 135    procedure Gmem_A2l_Initialize (Exename : String);
 136    --  Initialises the convert_addresses interface by supplying it with
 137    --  the name of the executable file Exename
 138
 139    procedure Gmem_Read_Next (Buf : out String; Last : out Natural);
 140    --  Reads the next allocation/deallocation entry and its backtrace
 141    --  and prepares in the string Buf (up to the position of Last) the
 142    --  expression compatible with gnatmem parser:
 143    --  Allocation entry produces the expression "ALLOC^[size]^0x[address]^"
 144    --  Deallocation entry produces the expression "DEALLOC^0x[address]^"
 145
 146    Argc        : constant Integer   := Argument_Count;
 147    Gnatmem_Tmp : aliased constant String    := "gnatmem.tmp";
 148
 149    Mode_R : aliased constant String (1 .. 2) := 'r'  & ASCII.NUL;
 150    Mode_W : aliased constant String (1 .. 3) := "w+" & ASCII.NUL;
 151
 152    -----------------------------------
 153    -- HTable address --> Allocation --
 154    -----------------------------------
 155
 156    type Allocation is record
 157       Root : Root_Id;
 158       Size : Storage_Count;
 159    end record;
 160
 161    type Address_Range is range 0 .. 4097;
 162    function H (A : Integer_Address) return Address_Range;
 163    No_Alloc : constant Allocation := (No_Root_Id, 0);
 164
 165    package Address_HTable is new GNAT.HTable.Simple_HTable (
 166      Header_Num => Address_Range,
 167      Element    => Allocation,
 168      No_Element => No_Alloc,
 169      Key        => Integer_Address,
 170      Hash       => H,
 171      Equal      => "=");
 172
 173    BT_Depth   : Integer := 1;
 174    FD         : FILEs;
 175    FT         : File_Type;
 176    File_Pos   : Integer := 0;
 177    Exec_Pos   : Integer := 0;
 178    Target_Pos : Integer := 0;
 179    Run_Gdb    : Boolean := True;
 180
 181    Global_Alloc_Size      : Storage_Count  := 0;
 182    Global_High_Water_Mark : Storage_Count  := 0;
 183    Global_Nb_Alloc        : Integer        := 0;
 184    Global_Nb_Dealloc      : Integer        := 0;
 185    Nb_Root                : Integer        := 0;
 186    Nb_Wrong_Deall         : Integer        := 0;
 187    Target_Name            : String (1 .. 80);
 188    Target_Protocol        : String (1 .. 80);
 189    Target_Name_Len        : Integer;
 190    Target_Protocol_Len    : Integer;
 191    Cross_Case             : Boolean := False;
 192
 193    Tmp_Size    : Storage_Count  := 0;
 194    Tmp_Address : Integer_Address;
 195    Tmp_Alloc   : Allocation;
 196    Quiet_Mode  : Boolean := False;
 197
 198    --------------------------------
 199    -- GMEM functionality binding --
 200    --------------------------------
 201
 202    function Gmem_Initialize (Dumpname : String) return Boolean is
 203       function Initialize (Dumpname : System.Address) return Boolean;
 204       pragma Import (C, Initialize, "__gnat_gmem_initialize");
 205       S : aliased String := Dumpname & ASCII.NUL;
 206    begin
 207       return Initialize (S'Address);
 208    end Gmem_Initialize;
 209
 210    procedure Gmem_A2l_Initialize (Exename : String) is
 211       procedure A2l_Initialize (Exename : System.Address);
 212       pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
 213       S : aliased String := Exename & ASCII.NUL;
 214    begin
 215       A2l_Initialize (S'Address);
 216    end Gmem_A2l_Initialize;
 217
 218    procedure Gmem_Read_Next (Buf : out String; Last : out Natural) is
 219       procedure Read_Next (buf : System.Address);
 220       pragma Import (C, Read_Next, "__gnat_gmem_read_next");
 221       function Strlen (str : System.Address) return Natural;
 222       pragma Import (C, Strlen, "strlen");
 223
 224       S : String (1 .. 1000);
 225    begin
 226       Read_Next (S'Address);
 227       Last := Strlen (S'Address);
 228       Buf (1 .. Last) := S (1 .. Last);
 229    end Gmem_Read_Next;
 230
 231    ---------------------
 232    -- Get_Current_TTY --
 233    ---------------------
 234
 235    function Get_Current_TTY return String is
 236       Res          :  Cstring_Ptr;
 237       stdout       : constant Integer := 1;
 238       Max_TTY_Name : constant Integer := 500;
 239
 240    begin
 241       if isatty (stdout) /= 1 then
 242          return "";
 243       end if;
 244
 245       Res := ttyname (1);
 246       if Res /= null then
 247          for J in Cstring'First .. Max_TTY_Name loop
 248             if Res (J) = ASCII.NUL then
 249                return Res (Cstring'First .. J - 1);
 250             end if;
 251          end loop;
 252       end if;
 253
 254       --  if we fall thru the ttyname result was dubious. Just forget it.
 255
 256       return "";
 257    end Get_Current_TTY;
 258
 259    -------
 260    -- H --
 261    -------
 262
 263    function H (A : Integer_Address) return Address_Range is
 264    begin
 265       return Address_Range (A mod Integer_Address (Address_Range'Last));
 266    end H;
 267
 268    -----------------------
 269    -- Create_Gdb_Script --
 270    -----------------------
 271
 272    procedure Create_Gdb_Script is
 273       FD : File_Type;
 274
 275    begin
 276       begin
 277          Create (FD, Out_File, Gnatmem_Tmp);
 278       exception
 279          when others =>
 280             Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp);
 281             GNAT.OS_Lib.OS_Exit (1);
 282       end;
 283
 284       declare
 285          TTY : constant String := Get_Current_TTY;
 286       begin
 287          if TTY'Length > 0 then
 288             Put_Line (FD, "tty " & TTY);
 289          end if;
 290       end;
 291
 292       if Cross_Case then
 293          Put (FD, "target ");
 294          Put (FD, Target_Protocol (1 .. Target_Protocol_Len));
 295          Put (FD, " ");
 296          Put (FD, Argument (Target_Pos));
 297          New_Line (FD);
 298          Put (FD, "load ");
 299          Put_Line (FD, Argument (Exec_Pos));
 300
 301       else
 302          --  In the native case, run the program before setting the
 303          --  breakpoints so that gnatmem will also work with shared
 304          --  libraries.
 305
 306          Put_Line (FD, "set lang c");
 307          Put_Line (FD, "break main");
 308          Put_Line (FD, "set lang auto");
 309          Put      (FD, "run");
 310          for J in Exec_Pos + 1 .. Argc loop
 311             Put (FD, " ");
 312             Put (FD, Argument (J));
 313          end loop;
 314          New_Line (FD);
 315
 316          --  At this point, gdb knows about __gnat_malloc and __gnat_free
 317       end if;
 318
 319       --  Make sure that outputing long backtraces do not pause
 320
 321       Put_Line (FD, "set height 0");
 322       Put_Line (FD, "set width 0");
 323
 324       if Quiet_Mode then
 325          Put_Line (FD, "break __gnat_malloc");
 326          Put_Line (FD, "command");
 327          Put_Line (FD, "   silent");
 328          Put_Line (FD, "   set lang c");
 329          Put_Line (FD, "   set print address on");
 330          Put_Line (FD, "   up");
 331          Put_Line (FD, "   set $gm_addr = $pc");
 332          Put_Line (FD, "   printf ""\n\n""");
 333          Put_Line (FD, "   printf ""ALLOC^0x%x^\n"", $gm_addr");
 334          Put_Line (FD, "   set print address off");
 335          Put_Line (FD, "   set lang auto");
 336       else
 337          Put_Line (FD, "break __gnat_malloc");
 338          Put_Line (FD, "command");
 339          Put_Line (FD, "   silent");
 340          Put_Line (FD, "   set lang c");
 341          Put_Line (FD, "   set $gm_size = size");
 342          Put_Line (FD, "   set print address on");
 343          Put_Line (FD, "   up");
 344          Put_Line (FD, "   set $gm_addr = $pc");
 345          Put_Line (FD, "   printf ""\n\n""");
 346          Put_Line (FD, "   printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr");
 347          Put_Line (FD, "   set print address off");
 348          Put_Line (FD, "   set lang auto");
 349       end if;
 350
 351       Put (FD, "   backtrace");
 352
 353       if BT_Depth /= 0 then
 354          Put (FD, Integer'Image (BT_Depth + 1));
 355       end if;
 356
 357       New_Line (FD);
 358
 359       Put_Line (FD, "   printf ""\n\n""");
 360       Put_Line (FD, "   continue");
 361       Put_Line (FD, "end");
 362       Put_Line (FD, "#");
 363       Put_Line (FD, "#");
 364       Put_Line (FD, "break __gnat_free");
 365       Put_Line (FD, "command");
 366       Put_Line (FD, "   silent");
 367       Put_Line (FD, "   set print address on");
 368       Put_Line (FD, "   printf ""\n\n""");
 369       Put_Line (FD, "   printf ""DEALL^0x%x^\n"", ptr");
 370       Put_Line (FD, "   set print address off");
 371       Put_Line (FD, "   up");
 372
 373       Put (FD, "   backtrace");
 374
 375       if BT_Depth /= 0 then
 376          Put (FD, Integer'Image (BT_Depth + 1));
 377       end if;
 378
 379       New_Line (FD);
 380
 381       Put_Line (FD, "   printf ""\n\n""");
 382       Put_Line (FD, "   continue");
 383       Put_Line (FD, "end");
 384       Put_Line (FD, "#");
 385       Put_Line (FD, "#");
 386       Put_Line (FD, "#");
 387
 388       if Cross_Case then
 389          Put (FD, "run ");
 390          Put_Line (FD, Argument (Exec_Pos));
 391
 392          if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then
 393             Put (FD, "unload ");
 394             Put_Line (FD, Argument (Exec_Pos));
 395          end if;
 396       else
 397          Put_Line (FD, "continue");
 398       end if;
 399
 400       Close (FD);
 401    end Create_Gdb_Script;
 402
 403    ---------------
 404    -- Mem_Image --
 405    ---------------
 406
 407    function Mem_Image (X : Storage_Count) return String is
 408       Ks    : constant Storage_Count := X / 1024;
 409       Megs  : constant Storage_Count := Ks / 1024;
 410       Buff  : String (1 .. 7);
 411
 412    begin
 413       if Megs /= 0 then
 414          Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
 415          return Buff & " Megabytes";
 416
 417       elsif Ks /= 0 then
 418          Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
 419          return Buff & " Kilobytes";
 420
 421       else
 422          Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
 423          return  Buff (1 .. 4) & " Bytes";
 424       end if;
 425    end Mem_Image;
 426
 427    -----------
 428    -- Usage --
 429    -----------
 430
 431    procedure Usage is
 432    begin
 433       New_Line;
 434       Put ("GNATMEM ");
 435       Put (Gnat_Version_String);
 436       Put_Line (" Copyright 1997-2002 Free Software Foundation, Inc.");
 437       New_Line;
 438
 439       if Cross_Case then
 440          Put_Line (Command_Name
 441            & " [-q] [n] [-o file] target entry_point ...");
 442          Put_Line (Command_Name & " [-q] [n] [-i file]");
 443
 444       else
 445          Put_Line ("GDB mode");
 446          Put_Line ("   " & Command_Name
 447                    & " [-q] [n] [-o file] program arg1 arg2 ...");
 448          Put_Line ("   " & Command_Name
 449                    & " [-q] [n] [-i file]");
 450          New_Line;
 451          Put_Line ("GMEM mode");
 452          Put_Line ("   " & Command_Name
 453                    & " [-q] [n] -i gmem.out program arg1 arg2 ...");
 454          New_Line;
 455       end if;
 456
 457       Put_Line ("  -q       quiet, minimum output");
 458       Put_Line ("   n       number of frames for allocation root backtraces");
 459       Put_Line ("           default is 1.");
 460       Put_Line ("  -o file  save gdb output in 'file' and process data");
 461       Put_Line ("           post mortem. also keep the gdb script around");
 462       Put_Line ("  -i file  don't run gdb output. Do only post mortem");
 463       Put_Line ("           processing from file");
 464       GNAT.OS_Lib.OS_Exit (1);
 465    end Usage;
 466
 467    -----------------------
 468    -- Process_Arguments --
 469    -----------------------
 470
 471    procedure Process_Arguments is
 472       Arg : Integer;
 473
 474       procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False);
 475       --  Check that Argument (Arg_Pos) is an existing file if For_Creat is
 476       --  false or if it is possible to create it if For_Creat is true
 477
 478       procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False) is
 479          Name : aliased constant String := Argument (Arg_Pos) & ASCII.NUL;
 480          X    : int;
 481
 482       begin
 483          if For_Creat then
 484             FD := fopen (Name'Address, Mode_W'Address);
 485          else
 486             FD := fopen (Name'Address, Mode_R'Address);
 487          end if;
 488
 489          if FD = NULL_Stream then
 490             New_Line;
 491             if For_Creat then
 492                Put_Line ("Cannot create file : " & Argument (Arg_Pos));
 493             else
 494                Put_Line ("Cannot locate file : " & Argument (Arg_Pos));
 495             end if;
 496             New_Line;
 497             Usage;
 498          else
 499             X := fclose (FD);
 500          end if;
 501       end Check_File;
 502
 503    --  Start of processing for Process_Arguments
 504
 505    begin
 506
 507       --  Is it a cross version?
 508
 509       declare
 510          Std_Name : constant String  := "gnatmem";
 511          Name     : constant String  := Command_Name;
 512          End_Pref : constant Integer := Name'Last - Std_Name'Length;
 513
 514       begin
 515          if Name'Length > Std_Name'Length + 9
 516            and then
 517              Name (End_Pref + 1 .. Name'Last) = Std_Name
 518            and then
 519              Name (End_Pref - 8 .. End_Pref) = "-vxworks-"
 520          then
 521             Cross_Case := True;
 522
 523             Target_Name_Len := End_Pref - 1;
 524             for J in reverse Name'First .. End_Pref - 1 loop
 525                if Name (J) = Dir_Sep then
 526                   Target_Name_Len := Target_Name_Len - J;
 527                   exit;
 528                end if;
 529             end loop;
 530
 531             Target_Name (1 .. Target_Name_Len)
 532               := Name (End_Pref - Target_Name_Len  .. End_Pref - 1);
 533
 534             if Target_Name (1 .. 5) = "alpha" then
 535                Target_Protocol (1 .. 7) := "vxworks";
 536                Target_Protocol_Len := 7;
 537             else
 538                Target_Protocol (1 .. 3) := "wtx";
 539                Target_Protocol_Len := 3;
 540             end if;
 541          end if;
 542       end;
 543
 544       Arg := 1;
 545
 546       if Argc < Arg then
 547          Usage;
 548       end if;
 549
 550       --  Deal with "-q"
 551
 552       if Argument (Arg) = "-q" then
 553
 554          Quiet_Mode := True;
 555          Arg := Arg + 1;
 556
 557          if Argc < Arg then
 558             Usage;
 559          end if;
 560       end if;
 561
 562       --  Deal with back trace depth
 563
 564       if Argument (Arg) (1) in '0' .. '9' then
 565          begin
 566             BT_Depth := Integer'Value (Argument (Arg));
 567          exception
 568             when others =>
 569                Usage;
 570          end;
 571
 572          Arg := Arg + 1;
 573
 574          if Argc < Arg then
 575             Usage;
 576          end if;
 577       end if;
 578
 579       --  Deal with "-o file" or "-i file"
 580
 581       while Arg <= Argc and then Argument (Arg) (1) = '-' loop
 582          Arg := Arg + 1;
 583
 584          if Argc < Arg then
 585             Usage;
 586          end if;
 587
 588          case Argument (Arg - 1) (2) is
 589             when 'o' =>
 590                Check_File (Arg, For_Creat => True);
 591                File_Pos := Arg;
 592
 593             when 'i' =>
 594                Check_File (Arg);
 595                File_Pos := Arg;
 596                Run_Gdb  := False;
 597                if Gmem_Initialize (Argument (Arg)) then
 598                   Gmem_Mode := True;
 599                end if;
 600
 601             when others =>
 602                Put_Line ("Unknown option : " & Argument (Arg));
 603                Usage;
 604          end case;
 605
 606          Arg := Arg + 1;
 607
 608          if Argc < Arg and then Run_Gdb then
 609             Usage;
 610          end if;
 611       end loop;
 612
 613       --  In the cross case, we first get the target
 614
 615       if Cross_Case then
 616          Target_Pos := Arg;
 617          Arg := Arg + 1;
 618
 619          if Argc < Arg and then Run_Gdb then
 620             Usage;
 621          end if;
 622       end if;
 623
 624       --  Now all the following arguments are to be passed to gdb
 625
 626       if Run_Gdb then
 627          Exec_Pos := Arg;
 628          Check_File (Exec_Pos);
 629
 630       elsif Gmem_Mode then
 631          if Arg > Argc then
 632             Usage;
 633          else
 634             Exec_Pos := Arg;
 635             Check_File (Exec_Pos);
 636             Gmem_A2l_Initialize (Argument (Exec_Pos));
 637          end if;
 638
 639       --  ... in other cases further arguments are disallowed
 640
 641       elsif Arg <= Argc then
 642          Usage;
 643       end if;
 644    end Process_Arguments;
 645
 646    ---------------
 647    -- Read_Next --
 648    ---------------
 649
 650    function Read_Next return Gdb_Output_Elmt is
 651       Max_Line : constant Integer   := 100;
 652       Line     : String (1 .. Max_Line);
 653       Last     : Integer := 0;
 654
 655       Curs1, Curs2 : Integer;
 656       Separator    : constant Character := '^';
 657
 658       function Next_Separator return Integer;
 659       --  Return the index of the next separator after Curs1 in Line
 660
 661       function Next_Separator return Integer is
 662          Curs : Integer := Curs1;
 663
 664       begin
 665          loop
 666             if Curs > Last then
 667                raise Gdb_Output_Format_Error;
 668
 669             elsif Line (Curs) = Separator then
 670                return Curs;
 671             end if;
 672
 673             Curs := Curs + 1;
 674          end loop;
 675       end Next_Separator;
 676
 677    --  Start of processing for Read_Next
 678
 679    begin
 680       Line (1) := ' ';
 681
 682       loop
 683          if Gmem_Mode then
 684             Gmem_Read_Next (Line, Last);
 685          else
 686             Get_Line (FT, Line, Last);
 687          end if;
 688
 689          if Line (1 .. 14) = "Program exited" then
 690             return Eof;
 691
 692          elsif Line (1 .. 5) = "ALLOC" then
 693             --  ALLOC ^ <size> ^0x <addr> ^
 694
 695             --  Read the size
 696
 697             Curs1 := 7;
 698             Curs2 := Next_Separator - 1;
 699
 700             if not Quiet_Mode then
 701                Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2));
 702             end if;
 703
 704             --  Read the address, skip "^0x"
 705
 706             Curs1 := Curs2 + 4;
 707             Curs2 := Next_Separator - 1;
 708             Tmp_Address := Integer_Address'Value (
 709                                "16#" & Line (Curs1 .. Curs2) & "#");
 710             return Alloc;
 711
 712          elsif Line (1 .. 5) = "DEALL" then
 713             --  DEALL ^ 0x <addr> ^
 714
 715             --  Read the address, skip "^0x"
 716
 717             Curs1 := 9;
 718             Curs2 := Next_Separator - 1;
 719             Tmp_Address := Integer_Address'Value (
 720                                "16#" & Line (Curs1 .. Curs2) & "#");
 721             return Deall;
 722          end if;
 723       end loop;
 724    exception
 725       when End_Error =>
 726          New_Line;
 727          Put_Line ("### incorrect user program  termination detected.");
 728          Put_Line ("    following data may not be meaningful");
 729          New_Line;
 730          return Eof;
 731    end Read_Next;
 732
 733 --  Start of processing for Gnatmem
 734
 735 begin
 736    Process_Arguments;
 737
 738    if Run_Gdb then
 739       Create_Gdb_Script;
 740    end if;
 741
 742    --  Now we start the gdb session using the following syntax
 743
 744    --     gdb --nx --nw -batch -x gnatmem.tmp
 745
 746    --  If there is a -o option we redirect the gdb output in the specified
 747    --  file, otherwise we just read directly from a pipe.
 748
 749    if File_Pos /= 0 then
 750       declare
 751          Name : aliased String := Argument (File_Pos) & ASCII.NUL;
 752
 753       begin
 754          if Run_Gdb then
 755             if Cross_Case then
 756                declare
 757                   Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
 758                     & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & " > "
 759                     & Name;
 760                begin
 761                   System_Cmd (Cmd'Address);
 762                end;
 763             else
 764
 765                declare
 766                   Cmd : aliased String
 767                     := "gdb --nx --nw " & Argument (Exec_Pos)
 768                            & " -batch -x " & Gnatmem_Tmp & " > "
 769                            & Name;
 770                begin
 771                   System_Cmd (Cmd'Address);
 772                end;
 773             end if;
 774          end if;
 775
 776          if not Gmem_Mode then
 777             FD := fopen (Name'Address, Mode_R'Address);
 778          end if;
 779       end;
 780
 781    else
 782       if Cross_Case then
 783          declare
 784             Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
 785               & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & ASCII.NUL;
 786          begin
 787             FD := popen (Cmd'Address, Mode_R'Address);
 788          end;
 789       else
 790          declare
 791             Cmd : aliased String := "gdb --nx --nw " & Argument (Exec_Pos)
 792               & " -batch -x " & Gnatmem_Tmp & ASCII.NUL;
 793
 794          begin
 795             FD := popen (Cmd'Address, Mode_R'Address);
 796          end;
 797       end if;
 798    end if;
 799
 800    --  Open the FD file as a regular Text_IO file
 801
 802    if not Gmem_Mode then
 803       Ada.Text_IO.C_Streams.Open (FT, In_File, FD);
 804    end if;
 805
 806    --  Main loop  analysing the data generated by the debugger
 807    --  for each allocation, the backtrace is kept and stored in a htable
 808    --  whose entry is the address. Fore ach deallocation, we look for the
 809    --  corresponding allocation and cancel it.
 810
 811    Main : loop
 812       case Read_Next is
 813          when EOF =>
 814             exit Main;
 815
 816          when Alloc =>
 817
 818             --  Update global counters if the allocated size is meaningful
 819
 820             if Quiet_Mode then
 821                Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
 822                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 823                   Nb_Root := Nb_Root + 1;
 824                end if;
 825                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
 826                Address_HTable.Set (Tmp_Address, Tmp_Alloc);
 827
 828             elsif Tmp_Size > 0 then
 829
 830                Global_Alloc_Size := Global_Alloc_Size + Tmp_Size;
 831                Global_Nb_Alloc   := Global_Nb_Alloc + 1;
 832
 833                if Global_High_Water_Mark < Global_Alloc_Size then
 834                   Global_High_Water_Mark := Global_Alloc_Size;
 835                end if;
 836
 837                --  Read the corresponding back trace
 838
 839                Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
 840
 841                --  Update the number of allocation root if this is a new one
 842
 843                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 844                   Nb_Root := Nb_Root + 1;
 845                end if;
 846
 847                --  Update allocation root specific counters
 848
 849                Set_Alloc_Size (Tmp_Alloc.Root,
 850                  Alloc_Size (Tmp_Alloc.Root) + Tmp_Size);
 851
 852                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
 853
 854                if High_Water_Mark (Tmp_Alloc.Root)
 855                   < Alloc_Size (Tmp_Alloc.Root)
 856                then
 857                   Set_High_Water_Mark (Tmp_Alloc.Root,
 858                     Alloc_Size (Tmp_Alloc.Root));
 859                end if;
 860
 861                --  Associate this allocation root to the allocated address
 862
 863                Tmp_Alloc.Size := Tmp_Size;
 864                Address_HTable.Set (Tmp_Address, Tmp_Alloc);
 865
 866             --  non meaninful output, just consumes the backtrace
 867
 868             else
 869                Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
 870             end if;
 871
 872          when Deall =>
 873
 874             --  Get the corresponding Dealloc_Size and Root
 875
 876             Tmp_Alloc := Address_HTable.Get (Tmp_Address);
 877
 878             if Tmp_Alloc.Root = No_Root_Id then
 879
 880                --  There was no prior allocation at this address, something is
 881                --  very wrong. Mark this allocation root as problematic a
 882
 883                Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
 884
 885                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 886                   Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
 887                   Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
 888                end if;
 889
 890             else
 891                --  Update global counters
 892
 893                if not Quiet_Mode then
 894                   Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
 895                end if;
 896                Global_Nb_Dealloc   := Global_Nb_Dealloc + 1;
 897
 898                --  Update allocation root specific counters
 899
 900                if not Quiet_Mode then
 901                   Set_Alloc_Size (Tmp_Alloc.Root,
 902                     Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
 903                end if;
 904                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
 905
 906                --  update the number of allocation root if this one disappear
 907
 908                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 909                   Nb_Root := Nb_Root - 1;
 910                end if;
 911
 912                --  De-associate the deallocated address
 913
 914                Address_HTable.Remove (Tmp_Address);
 915             end if;
 916       end case;
 917    end loop Main;
 918
 919    --  We can get rid of the temp file now
 920
 921    if Run_Gdb and then File_Pos = 0 then
 922       declare
 923          X : int;
 924       begin
 925          X := unlink (Gnatmem_Tmp'Address);
 926       end;
 927    end if;
 928
 929    --  Print out general information about overall allocation
 930
 931    if not Quiet_Mode then
 932       Put_Line ("Global information");
 933       Put_Line ("------------------");
 934
 935       Put      ("   Total number of allocations        :");
 936       Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
 937       New_Line;
 938
 939       Put      ("   Total number of deallocations      :");
 940       Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
 941       New_Line;
 942
 943       Put_Line ("   Final Water Mark (non freed mem)   :"
 944         & Mem_Image (Global_Alloc_Size));
 945       Put_Line ("   High Water Mark                    :"
 946         & Mem_Image (Global_High_Water_Mark));
 947       New_Line;
 948    end if;
 949
 950    --  Print out the back traces corresponding to potential leaks in order
 951    --  greatest number of non-deallocated allocations
 952
 953    Print_Back_Traces : declare
 954       type Root_Array is array (Natural range <>) of Root_Id;
 955       Leaks   : Root_Array (0 .. Nb_Root);
 956       Leak_Index   : Natural := 0;
 957
 958       Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
 959       Deall_Index  : Natural := 0;
 960
 961       procedure Move (From : Natural; To : Natural);
 962       function  Lt (Op1, Op2 : Natural) return Boolean;
 963       package   Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
 964
 965       procedure Move (From : Natural; To : Natural) is
 966       begin
 967          Leaks (To) := Leaks (From);
 968       end Move;
 969
 970       function Lt (Op1, Op2 : Natural) return Boolean is
 971       begin
 972          if Nb_Alloc (Leaks (Op1)) > Nb_Alloc (Leaks (Op2)) then
 973             return True;
 974          elsif  Nb_Alloc (Leaks (Op1)) = Nb_Alloc (Leaks (Op2)) then
 975             return Alloc_Size (Leaks (Op1)) > Alloc_Size (Leaks (Op2));
 976          else
 977             return False;
 978          end if;
 979       end Lt;
 980
 981    --  Start of processing for Print_Back_Traces
 982
 983    begin
 984       --  Transfer all the relevant Roots in the Leaks and a
 985       --  Bogus_Deall arrays
 986
 987       Tmp_Alloc.Root := Get_First;
 988       while Tmp_Alloc.Root /= No_Root_Id loop
 989          if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 990             null;
 991
 992          elsif Nb_Alloc (Tmp_Alloc.Root) < 0  then
 993             Deall_Index := Deall_Index + 1;
 994             Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
 995
 996          else
 997             Leak_Index := Leak_Index + 1;
 998             Leaks (Leak_Index) := Tmp_Alloc.Root;
 999          end if;
1000
1001          Tmp_Alloc.Root := Get_Next;
1002       end loop;
1003
1004       --  Print out wrong deallocations
1005
1006       if Nb_Wrong_Deall > 0 then
1007          Put_Line    ("Releasing deallocated memory at :");
1008          if not Quiet_Mode then
1009             Put_Line ("--------------------------------");
1010          end if;
1011
1012          for J in  1 .. Bogus_Dealls'Last loop
1013             Print_BT (Bogus_Dealls (J));
1014             New_Line;
1015          end loop;
1016       end if;
1017
1018       --  Print out all allocation Leaks
1019
1020       if Nb_Root > 0 then
1021
1022          --  Sort the Leaks so that potentially important leaks appear first
1023
1024          Root_Sort.Sort (Nb_Root);
1025
1026          for J in  1 .. Leaks'Last loop
1027             if Quiet_Mode then
1028                if Nb_Alloc (Leaks (J)) = 1 then
1029                   Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
1030                     & " leak at :");
1031                else
1032                   Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
1033                     & " leaks at :");
1034                end if;
1035             else
1036                Put_Line ("Allocation Root #" & Integer'Image (J));
1037                Put_Line ("-------------------");
1038
1039                Put      (" Number of non freed allocations    :");
1040                Ada.Integer_Text_IO.Put (Nb_Alloc (Leaks (J)), 4);
1041                New_Line;
1042
1043                Put_Line (" Final Water Mark (non freed mem)   :"
1044                  & Mem_Image (Alloc_Size (Leaks (J))));
1045
1046                Put_Line (" High Water Mark                    :"
1047                  & Mem_Image (High_Water_Mark (Leaks (J))));
1048
1049                Put_Line (" Backtrace                          :");
1050             end if;
1051             Print_BT (Leaks (J));
1052             New_Line;
1053          end loop;
1054       end if;
1055    end Print_Back_Traces;
1056
1057 end Gnatmem;