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