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