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