OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [gnatmem.adb] - Blame information for rev 316

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.