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