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-2007, AdaCore                     --
  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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  GNATMEM is a utility that tracks memory leaks. It is based on a simple
  28 --  idea:
  29
  30 --      - Read the allocation log generated by the application linked using
  31 --        instrumented memory allocation and dealocation (see memtrack.adb for
  32 --        this circuitry). To get access to this functionality, the application
  33 --        must be relinked with library libgmem.a:
  34
  35 --            $ gnatmake my_prog -largs -lgmem
  36
  37 --        The running my_prog will produce a file named gmem.out that will be
  38 --        parsed by gnatmem.
  39
  40 --      - Record a reference to the allocated memory on each allocation call
  41
  42 --      - Suppress this reference on deallocation
  43
  44 --      - At the end of the program, remaining references are potential leaks.
  45 --        sort them out the best possible way in order to locate the root of
  46 --        the leak.
  47
  48 --   This capability is not supported on all platforms, please refer to
  49 --   memtrack.adb for further information.
  50
  51 --   In order to help finding out the real leaks,  the notion of "allocation
  52 --   root" is defined. An allocation root is a specific point in the program
  53 --   execution generating memory allocation where data is collected (such as
  54 --   number of allocations, amount of memory allocated, high water mark, etc.)
  55
  56 with Ada.Float_Text_IO;
  57 with Ada.Integer_Text_IO;
  58 with Ada.Text_IO;             use Ada.Text_IO;
  59
  60 with System;                  use System;
  61 with System.Storage_Elements; use System.Storage_Elements;
  62
  63 with GNAT.Command_Line;       use GNAT.Command_Line;
  64 with GNAT.Heap_Sort_G;
  65 with GNAT.OS_Lib;             use GNAT.OS_Lib;
  66 with GNAT.HTable;             use GNAT.HTable;
  67
  68 with Gnatvsn; use Gnatvsn;
  69 with Memroot; use Memroot;
  70
  71 procedure Gnatmem is
  72
  73    package Int_IO renames Ada.Integer_Text_IO;
  74
  75    ------------------------
  76    -- Other Declarations --
  77    ------------------------
  78
  79    type Storage_Elmt is record
  80       Elmt : Character;
  81       --  *  = End of log file
  82       --  A  = found a ALLOC mark in the log
  83       --  D  = found a DEALL mark in the log
  84
  85       Address : Integer_Address;
  86       Size    : Storage_Count;
  87       Timestamp : Duration;
  88    end record;
  89    --  This type is used to read heap operations from the log file.
  90    --  Elmt contains the type of the operation, which can be either
  91    --  allocation, deallocation, or a special mark indicating the
  92    --  end of the log file. Address is used to store address on the
  93    --  heap where a chunk was allocated/deallocated, size is only
  94    --  for A event and contains size of the allocation, and Timestamp
  95    --  is the clock value at the moment of allocation
  96
  97    Log_Name : String_Access;
  98    --  Holds the name of the heap operations log file
  99
 100    Program_Name : String_Access;
 101    --  Holds the name of the user executable
 102
 103    function Read_Next return Storage_Elmt;
 104    --  Reads next dynamic storage operation from the log file
 105
 106    function Mem_Image (X : Storage_Count) return String;
 107    --  X is a size in storage_element. Returns a value
 108    --  in Megabytes, Kilobytes or Bytes as appropriate.
 109
 110    procedure Process_Arguments;
 111    --  Read command line arguments
 112
 113    procedure Usage;
 114    --  Prints out the option help
 115
 116    function Gmem_Initialize (Dumpname : String) return Boolean;
 117    --  Opens the file represented by Dumpname and prepares it for
 118    --  work. Returns False if the file does not have the correct format, True
 119    --  otherwise.
 120
 121    procedure Gmem_A2l_Initialize (Exename : String);
 122    --  Initialises the convert_addresses interface by supplying it with
 123    --  the name of the executable file Exename
 124
 125    -----------------------------------
 126    -- HTable address --> Allocation --
 127    -----------------------------------
 128
 129    type Allocation is record
 130       Root : Root_Id;
 131       Size : Storage_Count;
 132    end record;
 133
 134    type Address_Range is range 0 .. 4097;
 135    function H (A : Integer_Address) return Address_Range;
 136    No_Alloc : constant Allocation := (No_Root_Id, 0);
 137
 138    package Address_HTable is new GNAT.HTable.Simple_HTable (
 139      Header_Num => Address_Range,
 140      Element    => Allocation,
 141      No_Element => No_Alloc,
 142      Key        => Integer_Address,
 143      Hash       => H,
 144      Equal      => "=");
 145
 146    BT_Depth   : Integer := 1;
 147
 148    --  Some global statistics
 149
 150    Global_Alloc_Size : Storage_Count := 0;
 151    --  Total number of bytes allocated during the lifetime of a program
 152
 153    Global_High_Water_Mark : Storage_Count := 0;
 154    --  Largest amount of storage ever in use during the lifetime
 155
 156    Global_Nb_Alloc : Integer := 0;
 157    --  Total number of allocations
 158
 159    Global_Nb_Dealloc : Integer := 0;
 160    --  Total number of deallocations
 161
 162    Nb_Root : Integer := 0;
 163    --  Total number of allocation roots
 164
 165    Nb_Wrong_Deall : Integer := 0;
 166    --  Total number of wrong deallocations (i.e. without matching alloc)
 167
 168    Minimum_Nb_Leaks : Integer := 1;
 169    --  How many unfreed allocs should be in a root for it to count as leak
 170
 171    T0 : Duration := 0.0;
 172    --  The moment at which memory allocation routines initialized (should
 173    --  be pretty close to the moment the program started since there are
 174    --  always some allocations at RTL elaboration
 175
 176    Tmp_Alloc     : Allocation;
 177    Dump_Log_Mode : Boolean := False;
 178    Quiet_Mode    : Boolean := False;
 179
 180    ------------------------------
 181    -- Allocation Roots Sorting --
 182    ------------------------------
 183
 184    Sort_Order : String (1 .. 3) := "nwh";
 185    --  This is the default order in which sorting criteria will be applied
 186    --  n -  Total number of unfreed allocations
 187    --  w -  Final watermark
 188    --  h -  High watermark
 189
 190    --------------------------------
 191    -- GMEM functionality binding --
 192    --------------------------------
 193
 194    ---------------------
 195    -- Gmem_Initialize --
 196    ---------------------
 197
 198    function Gmem_Initialize (Dumpname : String) return Boolean is
 199       function Initialize (Dumpname : System.Address) return Duration;
 200       pragma Import (C, Initialize, "__gnat_gmem_initialize");
 201
 202       S : aliased String := Dumpname & ASCII.NUL;
 203
 204    begin
 205       T0 := Initialize (S'Address);
 206       return T0 > 0.0;
 207    end Gmem_Initialize;
 208
 209    -------------------------
 210    -- Gmem_A2l_Initialize --
 211    -------------------------
 212
 213    procedure Gmem_A2l_Initialize (Exename : String) is
 214       procedure A2l_Initialize (Exename : System.Address);
 215       pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
 216
 217       S : aliased String := Exename & ASCII.NUL;
 218
 219    begin
 220       A2l_Initialize (S'Address);
 221    end Gmem_A2l_Initialize;
 222
 223    ---------------
 224    -- Read_Next --
 225    ---------------
 226
 227    function Read_Next return Storage_Elmt is
 228       procedure Read_Next (buf : System.Address);
 229       pragma Import (C, Read_Next, "__gnat_gmem_read_next");
 230
 231       S : Storage_Elmt;
 232
 233    begin
 234       Read_Next (S'Address);
 235       return S;
 236    end Read_Next;
 237
 238    -------
 239    -- H --
 240    -------
 241
 242    function H (A : Integer_Address) return Address_Range is
 243    begin
 244       return Address_Range (A mod Integer_Address (Address_Range'Last));
 245    end H;
 246
 247    ---------------
 248    -- Mem_Image --
 249    ---------------
 250
 251    function Mem_Image (X : Storage_Count) return String is
 252       Ks   : constant Storage_Count := X / 1024;
 253       Megs : constant Storage_Count := Ks / 1024;
 254       Buff : String (1 .. 7);
 255
 256    begin
 257       if Megs /= 0 then
 258          Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0 / 1024.0, 2, 0);
 259          return Buff & " Megabytes";
 260
 261       elsif Ks /= 0 then
 262          Ada.Float_Text_IO.Put (Buff, Float (X) / 1024.0, 2, 0);
 263          return Buff & " Kilobytes";
 264
 265       else
 266          Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
 267          return Buff (1 .. 4) & " Bytes";
 268       end if;
 269    end Mem_Image;
 270
 271    -----------
 272    -- Usage --
 273    -----------
 274
 275    procedure Usage is
 276    begin
 277       New_Line;
 278       Put ("GNATMEM ");
 279       Put_Line (Gnat_Version_String);
 280       Put_Line ("Copyright 1997-2007, Free Software Foundation, Inc.");
 281       New_Line;
 282
 283       Put_Line ("Usage: gnatmem switches [depth] exename");
 284       New_Line;
 285       Put_Line ("  depth    backtrace depth to take into account, default is"
 286                 & Integer'Image (BT_Depth));
 287       Put_Line ("  exename  the name of the executable to be analyzed");
 288       New_Line;
 289       Put_Line ("Switches:");
 290       Put_Line ("  -b n     same as depth parameter");
 291       Put_Line ("  -i file  read the allocation log from specific file");
 292       Put_Line ("           default is gmem.out in the current directory");
 293       Put_Line ("  -m n     masks roots with less than n leaks, default is 1");
 294       Put_Line ("           specify 0 to see even released allocation roots");
 295       Put_Line ("  -q       quiet, minimum output");
 296       Put_Line ("  -s order sort allocation roots according to an order of");
 297       Put_Line ("           sort criteria");
 298       GNAT.OS_Lib.OS_Exit (1);
 299    end Usage;
 300
 301    -----------------------
 302    -- Process_Arguments --
 303    -----------------------
 304
 305    procedure Process_Arguments is
 306    begin
 307       --  Parse the options first
 308
 309       loop
 310          case Getopt ("b: dd m: i: q s:") is
 311             when ASCII.Nul => exit;
 312
 313             when 'b' =>
 314                begin
 315                   BT_Depth := Natural'Value (Parameter);
 316                exception
 317                   when Constraint_Error =>
 318                      Usage;
 319                end;
 320
 321             when 'd' =>
 322                Dump_Log_Mode := True;
 323
 324             when 'm' =>
 325                begin
 326                   Minimum_Nb_Leaks := Natural'Value (Parameter);
 327                exception
 328                   when Constraint_Error =>
 329                      Usage;
 330                end;
 331
 332             when 'i' =>
 333                Log_Name := new String'(Parameter);
 334
 335             when 'q' =>
 336                Quiet_Mode := True;
 337
 338             when 's' =>
 339                declare
 340                   S : constant String (Sort_Order'Range) := Parameter;
 341                begin
 342                   for J in Sort_Order'Range loop
 343                      if S (J) = 'n' or else
 344                         S (J) = 'w' or else
 345                         S (J) = 'h'
 346                      then
 347                         Sort_Order (J) := S (J);
 348                      else
 349                         Put_Line ("Invalid sort criteria string.");
 350                         GNAT.OS_Lib.OS_Exit (1);
 351                      end if;
 352                   end loop;
 353                end;
 354
 355             when others =>
 356                null;
 357          end case;
 358       end loop;
 359
 360       --  Set default log file if -i hasn't been specified
 361
 362       if Log_Name = null then
 363          Log_Name := new String'("gmem.out");
 364       end if;
 365
 366       --  Get the optional backtrace length and program name
 367
 368       declare
 369          Str1 : constant String := GNAT.Command_Line.Get_Argument;
 370          Str2 : constant String := GNAT.Command_Line.Get_Argument;
 371
 372       begin
 373          if Str1 = "" then
 374             Usage;
 375          end if;
 376
 377          if Str2 = "" then
 378             Program_Name := new String'(Str1);
 379          else
 380             BT_Depth := Natural'Value (Str1);
 381             Program_Name := new String'(Str2);
 382          end if;
 383
 384       exception
 385          when Constraint_Error =>
 386             Usage;
 387       end;
 388
 389       --  Ensure presence of executable suffix in Program_Name
 390
 391       declare
 392          Suffix : String_Access := Get_Executable_Suffix;
 393          Tmp    : String_Access;
 394
 395       begin
 396          if Suffix.all /= ""
 397            and then
 398              Program_Name.all
 399               (Program_Name.all'Last - Suffix.all'Length + 1 ..
 400                                Program_Name.all'Last) /= Suffix.all
 401          then
 402             Tmp := new String'(Program_Name.all & Suffix.all);
 403             Free (Program_Name);
 404             Program_Name := Tmp;
 405          end if;
 406
 407          Free (Suffix);
 408
 409          --  Search the executable on the path. If not found in the PATH, we
 410          --  default to the current directory. Otherwise, libaddr2line will
 411          --  fail with an error:
 412
 413          --     (null): Bad address
 414
 415          Tmp := Locate_Exec_On_Path (Program_Name.all);
 416
 417          if Tmp = null then
 418             Tmp := new String'('.' & Directory_Separator & Program_Name.all);
 419          end if;
 420
 421          Free (Program_Name);
 422          Program_Name := Tmp;
 423       end;
 424
 425       if not Is_Regular_File (Log_Name.all) then
 426          Put_Line ("Couldn't find " & Log_Name.all);
 427          GNAT.OS_Lib.OS_Exit (1);
 428       end if;
 429
 430       if not Gmem_Initialize (Log_Name.all) then
 431          Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
 432          GNAT.OS_Lib.OS_Exit (1);
 433       end if;
 434
 435       if not Is_Regular_File (Program_Name.all) then
 436          Put_Line ("Couldn't find " & Program_Name.all);
 437       end if;
 438
 439       Gmem_A2l_Initialize (Program_Name.all);
 440
 441    exception
 442       when GNAT.Command_Line.Invalid_Switch =>
 443          Ada.Text_IO.Put_Line ("Invalid switch : "
 444                                & GNAT.Command_Line.Full_Switch);
 445          Usage;
 446    end Process_Arguments;
 447
 448    --  Local variables
 449
 450    Cur_Elmt : Storage_Elmt;
 451    Buff     : String (1 .. 16);
 452
 453 --  Start of processing for Gnatmem
 454
 455 begin
 456    Process_Arguments;
 457
 458    if Dump_Log_Mode then
 459       Put_Line ("Full dump of dynamic memory operations history");
 460       Put_Line ("----------------------------------------------");
 461
 462       declare
 463          function CTime (Clock : Address) return Address;
 464          pragma Import (C, CTime, "ctime");
 465
 466          Int_T0     : Integer := Integer (T0);
 467          CTime_Addr : constant Address := CTime (Int_T0'Address);
 468
 469          Buffer : String (1 .. 30);
 470          for Buffer'Address use CTime_Addr;
 471
 472       begin
 473          Put_Line ("Log started at T0 =" & Duration'Image (T0) & " ("
 474                    & Buffer (1 .. 24) & ")");
 475       end;
 476    end if;
 477
 478    --  Main loop analysing the data generated by the instrumented routines.
 479    --  For each allocation, the backtrace is kept and stored in a htable
 480    --  whose entry is the address. For each deallocation, we look for the
 481    --  corresponding allocation and cancel it.
 482
 483    Main : loop
 484       Cur_Elmt := Read_Next;
 485
 486       case Cur_Elmt.Elmt is
 487          when '*' =>
 488             exit Main;
 489
 490          when 'A' =>
 491
 492             --  Read the corresponding back trace
 493
 494             Tmp_Alloc.Root := Read_BT (BT_Depth);
 495
 496             if Quiet_Mode then
 497
 498                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 499                   Nb_Root := Nb_Root + 1;
 500                end if;
 501
 502                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
 503                Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
 504
 505             elsif Cur_Elmt.Size > 0 then
 506
 507                --  Update global counters if the allocated size is meaningful
 508
 509                Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
 510                Global_Nb_Alloc   := Global_Nb_Alloc + 1;
 511
 512                if Global_High_Water_Mark < Global_Alloc_Size then
 513                   Global_High_Water_Mark := Global_Alloc_Size;
 514                end if;
 515
 516                --  Update the number of allocation root if this is a new one
 517
 518                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 519                   Nb_Root := Nb_Root + 1;
 520                end if;
 521
 522                --  Update allocation root specific counters
 523
 524                Set_Alloc_Size (Tmp_Alloc.Root,
 525                  Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
 526
 527                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
 528
 529                if High_Water_Mark (Tmp_Alloc.Root) <
 530                                                Alloc_Size (Tmp_Alloc.Root)
 531                then
 532                   Set_High_Water_Mark (Tmp_Alloc.Root,
 533                     Alloc_Size (Tmp_Alloc.Root));
 534                end if;
 535
 536                --  Associate this allocation root to the allocated address
 537
 538                Tmp_Alloc.Size := Cur_Elmt.Size;
 539                Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
 540
 541             end if;
 542
 543          when 'D' =>
 544
 545             --  Get the corresponding Dealloc_Size and Root
 546
 547             Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
 548
 549             if Tmp_Alloc.Root = No_Root_Id then
 550
 551                --  There was no prior allocation at this address, something is
 552                --  very wrong. Mark this allocation root as problematic.
 553
 554                Tmp_Alloc.Root := Read_BT (BT_Depth);
 555
 556                if Nb_Alloc (Tmp_Alloc.Root) = 0 then
 557                   Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
 558                   Nb_Wrong_Deall := Nb_Wrong_Deall + 1;
 559                end if;
 560
 561             else
 562                --  Update global counters
 563
 564                if not Quiet_Mode then
 565                   Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
 566                end if;
 567
 568                Global_Nb_Dealloc   := Global_Nb_Dealloc + 1;
 569
 570                --  Update allocation root specific counters
 571
 572                if not Quiet_Mode then
 573                   Set_Alloc_Size (Tmp_Alloc.Root,
 574                     Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
 575                end if;
 576
 577                Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
 578
 579                --  Update the number of allocation root if this one disappears
 580
 581                if Nb_Alloc (Tmp_Alloc.Root) = 0
 582                  and then Minimum_Nb_Leaks > 0 then
 583                   Nb_Root := Nb_Root - 1;
 584                end if;
 585
 586                --  Deassociate the deallocated address
 587
 588                Address_HTable.Remove (Cur_Elmt.Address);
 589             end if;
 590
 591          when others =>
 592             raise Program_Error;
 593       end case;
 594
 595       if Dump_Log_Mode then
 596          case Cur_Elmt.Elmt is
 597             when 'A' =>
 598                Put ("ALLOC");
 599                Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
 600                Put (Buff);
 601                Int_IO.Put (Buff (1 .. 8), Integer (Cur_Elmt.Size));
 602                Put (Buff (1 .. 8) & " bytes at moment T0 +");
 603                Put_Line (Duration'Image (Cur_Elmt.Timestamp - T0));
 604
 605             when 'D' =>
 606                Put ("DEALL");
 607                Int_IO.Put (Buff (1 .. 16), Integer (Cur_Elmt.Address), 16);
 608                Put (Buff);
 609                Put_Line (" at moment T0 +"
 610                          & Duration'Image (Cur_Elmt.Timestamp - T0));
 611             when others =>
 612                raise Program_Error;
 613          end case;
 614
 615          Print_BT (Tmp_Alloc.Root);
 616       end if;
 617
 618    end loop Main;
 619
 620    --  Print out general information about overall allocation
 621
 622    if not Quiet_Mode then
 623       Put_Line ("Global information");
 624       Put_Line ("------------------");
 625
 626       Put      ("   Total number of allocations        :");
 627       Ada.Integer_Text_IO.Put (Global_Nb_Alloc, 4);
 628       New_Line;
 629
 630       Put      ("   Total number of deallocations      :");
 631       Ada.Integer_Text_IO.Put (Global_Nb_Dealloc, 4);
 632       New_Line;
 633
 634       Put_Line ("   Final Water Mark (non freed mem)   :"
 635         & Mem_Image (Global_Alloc_Size));
 636       Put_Line ("   High Water Mark                    :"
 637         & Mem_Image (Global_High_Water_Mark));
 638       New_Line;
 639    end if;
 640
 641    --  Print out the back traces corresponding to potential leaks in order
 642    --  greatest number of non-deallocated allocations.
 643
 644    Print_Back_Traces : declare
 645       type Root_Array is array (Natural range <>) of Root_Id;
 646       type Access_Root_Array is access Root_Array;
 647
 648       Leaks        : constant Access_Root_Array :=
 649                        new Root_Array (0 .. Nb_Root);
 650       Leak_Index   : Natural := 0;
 651
 652       Bogus_Dealls : constant Access_Root_Array :=
 653                        new Root_Array (1 .. Nb_Wrong_Deall);
 654       Deall_Index  : Natural := 0;
 655       Nb_Alloc_J   : Natural := 0;
 656
 657       procedure Move (From : Natural; To : Natural);
 658       function Lt (Op1, Op2 : Natural) return Boolean;
 659       package Root_Sort is new GNAT.Heap_Sort_G (Move, Lt);
 660
 661       ----------
 662       -- Move --
 663       ----------
 664
 665       procedure Move (From : Natural; To : Natural) is
 666       begin
 667          Leaks (To) := Leaks (From);
 668       end Move;
 669
 670       --------
 671       -- Lt --
 672       --------
 673
 674       function Lt (Op1, Op2 : Natural) return Boolean is
 675
 676          function Apply_Sort_Criterion (S : Character) return Integer;
 677          --  Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
 678          --  smaller than, equal, or greater than Op2 according to criterion.
 679
 680          --------------------------
 681          -- Apply_Sort_Criterion --
 682          --------------------------
 683
 684          function Apply_Sort_Criterion (S : Character) return Integer is
 685             LOp1, LOp2 : Integer;
 686
 687          begin
 688             case S is
 689                when 'n' =>
 690                   LOp1 := Nb_Alloc (Leaks (Op1));
 691                   LOp2 := Nb_Alloc (Leaks (Op2));
 692
 693                when 'w' =>
 694                   LOp1 := Integer (Alloc_Size (Leaks (Op1)));
 695                   LOp2 := Integer (Alloc_Size (Leaks (Op2)));
 696
 697                when 'h' =>
 698                   LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
 699                   LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
 700
 701                when others =>
 702                   return 0;  --  Can't actually happen
 703             end case;
 704
 705             if LOp1 < LOp2 then
 706                return -1;
 707             elsif LOp1 > LOp2 then
 708                return 1;
 709             else
 710                return 0;
 711             end if;
 712
 713          exception
 714             when Constraint_Error =>
 715                return 0;
 716          end Apply_Sort_Criterion;
 717
 718          --  Local Variables
 719
 720          Result : Integer;
 721
 722       --  Start of processing for Lt
 723
 724       begin
 725          for S in Sort_Order'Range loop
 726             Result := Apply_Sort_Criterion (Sort_Order (S));
 727             if Result = -1 then
 728                return False;
 729             elsif Result = 1 then
 730                return True;
 731             end if;
 732          end loop;
 733          return False;
 734       end Lt;
 735
 736    --  Start of processing for Print_Back_Traces
 737
 738    begin
 739       --  Transfer all the relevant Roots in the Leaks and a Bogus_Deall arrays
 740
 741       Tmp_Alloc.Root := Get_First;
 742       while Tmp_Alloc.Root /= No_Root_Id loop
 743          if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_Nb_Leaks > 0 then
 744             null;
 745
 746          elsif Nb_Alloc (Tmp_Alloc.Root) < 0  then
 747             Deall_Index := Deall_Index + 1;
 748             Bogus_Dealls (Deall_Index) := Tmp_Alloc.Root;
 749
 750          else
 751             Leak_Index := Leak_Index + 1;
 752             Leaks (Leak_Index) := Tmp_Alloc.Root;
 753          end if;
 754
 755          Tmp_Alloc.Root := Get_Next;
 756       end loop;
 757
 758       --  Print out wrong deallocations
 759
 760       if Nb_Wrong_Deall > 0 then
 761          Put_Line    ("Releasing deallocated memory at :");
 762          if not Quiet_Mode then
 763             Put_Line ("--------------------------------");
 764          end if;
 765
 766          for J in  1 .. Bogus_Dealls'Last loop
 767             Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
 768             New_Line;
 769          end loop;
 770       end if;
 771
 772       --  Print out all allocation Leaks
 773
 774       if Leak_Index > 0 then
 775
 776          --  Sort the Leaks so that potentially important leaks appear first
 777
 778          Root_Sort.Sort (Leak_Index);
 779
 780          for J in  1 .. Leak_Index loop
 781             Nb_Alloc_J := Nb_Alloc (Leaks (J));
 782
 783             if Nb_Alloc_J >= Minimum_Nb_Leaks then
 784                if Quiet_Mode then
 785                   if Nb_Alloc_J = 1 then
 786                      Put_Line (" 1 leak at :");
 787                   else
 788                      Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
 789                   end if;
 790
 791                else
 792                   Put_Line ("Allocation Root #" & Integer'Image (J));
 793                   Put_Line ("-------------------");
 794
 795                   Put      (" Number of non freed allocations    :");
 796                   Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
 797                   New_Line;
 798
 799                   Put_Line
 800                     (" Final Water Mark (non freed mem)   :"
 801                      & Mem_Image (Alloc_Size (Leaks (J))));
 802
 803                   Put_Line
 804                     (" High Water Mark                    :"
 805                      & Mem_Image (High_Water_Mark (Leaks (J))));
 806
 807                   Put_Line (" Backtrace                          :");
 808                end if;
 809
 810                Print_BT (Leaks (J), Short => Quiet_Mode);
 811                New_Line;
 812             end if;
 813          end loop;
 814       end if;
 815    end Print_Back_Traces;
 816 end Gnatmem;