1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . D E B U G _ P O O L S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with GNAT.IO; use GNAT.IO; 33 34with System.CRTL; 35with System.Memory; use System.Memory; 36with System.Soft_Links; use System.Soft_Links; 37 38with System.Traceback_Entries; 39 40with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; 41with GNAT.HTable; 42with GNAT.Traceback; use GNAT.Traceback; 43 44with Ada.Finalization; 45with Ada.Unchecked_Conversion; 46 47package body GNAT.Debug_Pools is 48 49 Storage_Alignment : constant := Standard'Maximum_Alignment; 50 -- Alignment enforced for all the memory chunks returned by Allocate, 51 -- maximized to make sure that it will be compatible with all types. 52 -- 53 -- The addresses returned by the underlying low-level allocator (be it 54 -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned 55 -- on some targets, so we manage the needed alignment padding ourselves 56 -- systematically. Use of a common value for every allocation allows 57 -- significant simplifications in the code, nevertheless, for improved 58 -- robustness and efficiency overall. 59 60 -- We combine a few internal devices to offer the pool services: 61 -- 62 -- * A management header attached to each allocated memory block, located 63 -- right ahead of it, like so: 64 -- 65 -- Storage Address returned by the pool, 66 -- aligned on Storage_Alignment 67 -- v 68 -- +------+--------+--------------------- 69 -- | ~~~~ | HEADER | USER DATA ... | 70 -- +------+--------+--------------------- 71 -- <----> 72 -- alignment 73 -- padding 74 -- 75 -- The alignment padding is required 76 -- 77 -- * A validity bitmap, which holds a validity bit for blocks managed by 78 -- the pool. Enforcing Storage_Alignment on those blocks allows efficient 79 -- validity management. 80 -- 81 -- * A list of currently used blocks. 82 83 Max_Ignored_Levels : constant Natural := 10; 84 -- Maximum number of levels that will be ignored in backtraces. This is so 85 -- that we still have enough significant levels in the tracebacks returned 86 -- to the user. 87 -- 88 -- The value 10 is chosen as being greater than the maximum callgraph 89 -- in this package. Its actual value is not really relevant, as long as it 90 -- is high enough to make sure we still have enough frames to return to 91 -- the user after we have hidden the frames internal to this package. 92 93 Disable : Boolean := False; 94 -- This variable is used to avoid infinite loops, where this package would 95 -- itself allocate memory and then call itself recursively, forever. Useful 96 -- when System_Memory_Debug_Pool_Enabled is True. 97 98 System_Memory_Debug_Pool_Enabled : Boolean := False; 99 -- If True, System.Memory allocation uses Debug_Pool 100 101 Allow_Unhandled_Memory : Boolean := False; 102 -- If True, protects Deallocate against releasing memory allocated before 103 -- System_Memory_Debug_Pool_Enabled was set. 104 105 Traceback_Count : Byte_Count := 0; 106 -- Total number of traceback elements 107 108 --------------------------- 109 -- Back Trace Hash Table -- 110 --------------------------- 111 112 -- This package needs to store one set of tracebacks for each allocation 113 -- point (when was it allocated or deallocated). This would use too much 114 -- memory, so the tracebacks are actually stored in a hash table, and 115 -- we reference elements in this hash table instead. 116 117 -- This hash-table will remain empty if the discriminant Stack_Trace_Depth 118 -- for the pools is set to 0. 119 120 -- This table is a global table, that can be shared among all debug pools 121 -- with no problems. 122 123 type Header is range 1 .. 1023; 124 -- Number of elements in the hash-table 125 126 type Tracebacks_Array_Access is access Tracebacks_Array; 127 128 type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc); 129 130 type Traceback_Htable_Elem; 131 type Traceback_Htable_Elem_Ptr 132 is access Traceback_Htable_Elem; 133 134 type Traceback_Htable_Elem is record 135 Traceback : Tracebacks_Array_Access; 136 Kind : Traceback_Kind; 137 Count : Natural; 138 -- Size of the memory allocated/freed at Traceback since last Reset call 139 140 Total : Byte_Count; 141 -- Number of chunk of memory allocated/freed at Traceback since last 142 -- Reset call. 143 144 Frees : Natural; 145 -- Number of chunk of memory allocated at Traceback, currently freed 146 -- since last Reset call. (only for Alloc & Indirect_Alloc elements) 147 148 Total_Frees : Byte_Count; 149 -- Size of the memory allocated at Traceback, currently freed since last 150 -- Reset call. (only for Alloc & Indirect_Alloc elements) 151 152 Next : Traceback_Htable_Elem_Ptr; 153 end record; 154 155 -- Subprograms used for the Backtrace_Htable instantiation 156 157 procedure Set_Next 158 (E : Traceback_Htable_Elem_Ptr; 159 Next : Traceback_Htable_Elem_Ptr); 160 pragma Inline (Set_Next); 161 162 function Next 163 (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; 164 pragma Inline (Next); 165 166 function Get_Key 167 (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; 168 pragma Inline (Get_Key); 169 170 function Hash (T : Tracebacks_Array_Access) return Header; 171 pragma Inline (Hash); 172 173 function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; 174 -- Why is this not inlined??? 175 176 -- The hash table for back traces 177 178 package Backtrace_Htable is new GNAT.HTable.Static_HTable 179 (Header_Num => Header, 180 Element => Traceback_Htable_Elem, 181 Elmt_Ptr => Traceback_Htable_Elem_Ptr, 182 Null_Ptr => null, 183 Set_Next => Set_Next, 184 Next => Next, 185 Key => Tracebacks_Array_Access, 186 Get_Key => Get_Key, 187 Hash => Hash, 188 Equal => Equal); 189 190 ----------------------- 191 -- Allocations table -- 192 ----------------------- 193 194 type Allocation_Header; 195 type Allocation_Header_Access is access Allocation_Header; 196 197 type Traceback_Ptr_Or_Address is new System.Address; 198 -- A type that acts as a C union, and is either a System.Address or a 199 -- Traceback_Htable_Elem_Ptr. 200 201 -- The following record stores extra information that needs to be 202 -- memorized for each block allocated with the special debug pool. 203 204 type Allocation_Header is record 205 Allocation_Address : System.Address; 206 -- Address of the block returned by malloc, possibly unaligned 207 208 Block_Size : Storage_Offset; 209 -- Needed only for advanced freeing algorithms (traverse all allocated 210 -- blocks for potential references). This value is negated when the 211 -- chunk of memory has been logically freed by the application. This 212 -- chunk has not been physically released yet. 213 214 Alloc_Traceback : Traceback_Htable_Elem_Ptr; 215 -- ??? comment required 216 217 Dealloc_Traceback : Traceback_Ptr_Or_Address; 218 -- Pointer to the traceback for the allocation (if the memory chunk is 219 -- still valid), or to the first deallocation otherwise. Make sure this 220 -- is a thin pointer to save space. 221 -- 222 -- Dealloc_Traceback is also for blocks that are still allocated to 223 -- point to the previous block in the list. This saves space in this 224 -- header, and make manipulation of the lists of allocated pointers 225 -- faster. 226 227 Next : System.Address; 228 -- Point to the next block of the same type (either allocated or 229 -- logically freed) in memory. This points to the beginning of the user 230 -- data, and does not include the header of that block. 231 end record; 232 233 function Header_Of 234 (Address : System.Address) return Allocation_Header_Access; 235 pragma Inline (Header_Of); 236 -- Return the header corresponding to a previously allocated address 237 238 function To_Address is new Ada.Unchecked_Conversion 239 (Traceback_Ptr_Or_Address, System.Address); 240 241 function To_Address is new Ada.Unchecked_Conversion 242 (System.Address, Traceback_Ptr_Or_Address); 243 244 function To_Traceback is new Ada.Unchecked_Conversion 245 (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr); 246 247 function To_Traceback is new Ada.Unchecked_Conversion 248 (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address); 249 250 Header_Offset : constant Storage_Count := 251 (Allocation_Header'Object_Size / System.Storage_Unit); 252 -- Offset, in bytes, from start of allocation Header to start of User 253 -- data. The start of user data is assumed to be aligned at least as much 254 -- as what the header type requires, so applying this offset yields a 255 -- suitably aligned address as well. 256 257 Extra_Allocation : constant Storage_Count := 258 (Storage_Alignment - 1 + Header_Offset); 259 -- Amount we need to secure in addition to the user data for a given 260 -- allocation request: room for the allocation header plus worst-case 261 -- alignment padding. 262 263 ----------------------- 264 -- Local subprograms -- 265 ----------------------- 266 267 function Align (Addr : Integer_Address) return Integer_Address; 268 pragma Inline (Align); 269 -- Return the next address aligned on Storage_Alignment from Addr. 270 271 function Find_Or_Create_Traceback 272 (Pool : Debug_Pool; 273 Kind : Traceback_Kind; 274 Size : Storage_Count; 275 Ignored_Frame_Start : System.Address; 276 Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr; 277 -- Return an element matching the current traceback (omitting the frames 278 -- that are in the current package). If this traceback already existed in 279 -- the htable, a pointer to this is returned to spare memory. Null is 280 -- returned if the pool is set not to store tracebacks. If the traceback 281 -- already existed in the table, the count is incremented so that 282 -- Dump_Tracebacks returns useful results. All addresses up to, and 283 -- including, an address between Ignored_Frame_Start .. Ignored_Frame_End 284 -- are ignored. 285 286 function Output_File (Pool : Debug_Pool) return File_Type; 287 pragma Inline (Output_File); 288 -- Returns file_type on which error messages have to be generated for Pool 289 290 procedure Put_Line 291 (File : File_Type; 292 Depth : Natural; 293 Traceback : Tracebacks_Array_Access; 294 Ignored_Frame_Start : System.Address := System.Null_Address; 295 Ignored_Frame_End : System.Address := System.Null_Address); 296 -- Print Traceback to File. If Traceback is null, print the call_chain 297 -- at the current location, up to Depth levels, ignoring all addresses 298 -- up to the first one in the range: 299 -- Ignored_Frame_Start .. Ignored_Frame_End 300 301 procedure Stdout_Put (S : String); 302 -- Wrapper for Put that ensures we always write to stdout instead of the 303 -- current output file defined in GNAT.IO. 304 305 procedure Stdout_Put_Line (S : String); 306 -- Wrapper for Put_Line that ensures we always write to stdout instead of 307 -- the current output file defined in GNAT.IO. 308 309 procedure Print_Traceback 310 (Output_File : File_Type; 311 Prefix : String; 312 Traceback : Traceback_Htable_Elem_Ptr); 313 -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null. 314 315 procedure Print_Address (File : File_Type; Addr : Address); 316 -- Output System.Address without using secondary stack. 317 -- When System.Memory uses Debug_Pool, secondary stack cannot be used 318 -- during Allocate calls, as some Allocate calls are done to 319 -- register/initialize a secondary stack for a foreign thread. 320 -- During these calls, the secondary stack is not available yet. 321 322 package Validity is 323 function Is_Handled (Storage : System.Address) return Boolean; 324 pragma Inline (Is_Handled); 325 -- Return True if Storage is the address of a block that the debug pool 326 -- already had under its control. Used to allow System.Memory to use 327 -- Debug_Pools 328 329 function Is_Valid (Storage : System.Address) return Boolean; 330 pragma Inline (Is_Valid); 331 -- Return True if Storage is the address of a block that the debug pool 332 -- has under its control, in which case Header_Of may be used to access 333 -- the associated allocation header. 334 335 procedure Set_Valid (Storage : System.Address; Value : Boolean); 336 pragma Inline (Set_Valid); 337 -- Mark the address Storage as being under control of the memory pool 338 -- (if Value is True), or not (if Value is False). 339 340 Validity_Count : Byte_Count := 0; 341 -- Total number of validity elements 342 343 end Validity; 344 345 use Validity; 346 347 procedure Set_Dead_Beef 348 (Storage_Address : System.Address; 349 Size_In_Storage_Elements : Storage_Count); 350 -- Set the contents of the memory block pointed to by Storage_Address to 351 -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple 352 -- of the length of this pattern, the last instance may be partial. 353 354 procedure Free_Physically (Pool : in out Debug_Pool); 355 -- Start to physically release some memory to the system, until the amount 356 -- of logically (but not physically) freed memory is lower than the 357 -- expected amount in Pool. 358 359 procedure Allocate_End; 360 procedure Deallocate_End; 361 procedure Dereference_End; 362 -- These procedures are used as markers when computing the stacktraces, 363 -- so that addresses in the debug pool itself are not reported to the user. 364 365 Code_Address_For_Allocate_End : System.Address; 366 Code_Address_For_Deallocate_End : System.Address; 367 Code_Address_For_Dereference_End : System.Address; 368 -- Taking the address of the above procedures will not work on some 369 -- architectures (HPUX for instance). Thus we do the same thing that 370 -- is done in a-except.adb, and get the address of labels instead. 371 372 procedure Skip_Levels 373 (Depth : Natural; 374 Trace : Tracebacks_Array; 375 Start : out Natural; 376 Len : in out Natural; 377 Ignored_Frame_Start : System.Address; 378 Ignored_Frame_End : System.Address); 379 -- Set Start .. Len to the range of values from Trace that should be output 380 -- to the user. This range of values excludes any address prior to the 381 -- first one in Ignored_Frame_Start .. Ignored_Frame_End (basically 382 -- addresses internal to this package). Depth is the number of levels that 383 -- the user is interested in. 384 385 package STBE renames System.Traceback_Entries; 386 387 function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address 388 renames STBE.PC_For; 389 390 type Scope_Lock is 391 new Ada.Finalization.Limited_Controlled with null record; 392 -- Used to handle Lock_Task/Unlock_Task calls 393 394 overriding procedure Initialize (This : in out Scope_Lock); 395 -- Lock task on initialization 396 397 overriding procedure Finalize (This : in out Scope_Lock); 398 -- Unlock task on finalization 399 400 ---------------- 401 -- Initialize -- 402 ---------------- 403 404 procedure Initialize (This : in out Scope_Lock) is 405 pragma Unreferenced (This); 406 begin 407 Lock_Task.all; 408 end Initialize; 409 410 -------------- 411 -- Finalize -- 412 -------------- 413 414 procedure Finalize (This : in out Scope_Lock) is 415 pragma Unreferenced (This); 416 begin 417 Unlock_Task.all; 418 end Finalize; 419 420 ----------- 421 -- Align -- 422 ----------- 423 424 function Align (Addr : Integer_Address) return Integer_Address is 425 Factor : constant Integer_Address := Storage_Alignment; 426 begin 427 return ((Addr + Factor - 1) / Factor) * Factor; 428 end Align; 429 430 --------------- 431 -- Header_Of -- 432 --------------- 433 434 function Header_Of 435 (Address : System.Address) return Allocation_Header_Access 436 is 437 function Convert is 438 new Ada.Unchecked_Conversion 439 (System.Address, 440 Allocation_Header_Access); 441 begin 442 return Convert (Address - Header_Offset); 443 end Header_Of; 444 445 -------------- 446 -- Set_Next -- 447 -------------- 448 449 procedure Set_Next 450 (E : Traceback_Htable_Elem_Ptr; 451 Next : Traceback_Htable_Elem_Ptr) 452 is 453 begin 454 E.Next := Next; 455 end Set_Next; 456 457 ---------- 458 -- Next -- 459 ---------- 460 461 function Next 462 (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr 463 is 464 begin 465 return E.Next; 466 end Next; 467 468 ----------- 469 -- Equal -- 470 ----------- 471 472 function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is 473 use type Tracebacks_Array; 474 begin 475 return K1.all = K2.all; 476 end Equal; 477 478 ------------- 479 -- Get_Key -- 480 ------------- 481 482 function Get_Key 483 (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access 484 is 485 begin 486 return E.Traceback; 487 end Get_Key; 488 489 ---------- 490 -- Hash -- 491 ---------- 492 493 function Hash (T : Tracebacks_Array_Access) return Header is 494 Result : Integer_Address := 0; 495 496 begin 497 for X in T'Range loop 498 Result := Result + To_Integer (PC_For (T (X))); 499 end loop; 500 501 return Header (1 + Result mod Integer_Address (Header'Last)); 502 end Hash; 503 504 ----------------- 505 -- Output_File -- 506 ----------------- 507 508 function Output_File (Pool : Debug_Pool) return File_Type is 509 begin 510 if Pool.Errors_To_Stdout then 511 return Standard_Output; 512 else 513 return Standard_Error; 514 end if; 515 end Output_File; 516 517 ------------------- 518 -- Print_Address -- 519 ------------------- 520 521 procedure Print_Address (File : File_Type; Addr : Address) is 522 begin 523 -- Warning: secondary stack cannot be used here. When System.Memory 524 -- implementation uses Debug_Pool, Print_Address can be called during 525 -- secondary stack creation for foreign threads. 526 527 Put (File, Image_C (Addr)); 528 end Print_Address; 529 530 -------------- 531 -- Put_Line -- 532 -------------- 533 534 procedure Put_Line 535 (File : File_Type; 536 Depth : Natural; 537 Traceback : Tracebacks_Array_Access; 538 Ignored_Frame_Start : System.Address := System.Null_Address; 539 Ignored_Frame_End : System.Address := System.Null_Address) 540 is 541 procedure Print (Tr : Tracebacks_Array); 542 -- Print the traceback to standard_output 543 544 ----------- 545 -- Print -- 546 ----------- 547 548 procedure Print (Tr : Tracebacks_Array) is 549 begin 550 for J in Tr'Range loop 551 Print_Address (File, PC_For (Tr (J))); 552 Put (File, ' '); 553 end loop; 554 Put (File, ASCII.LF); 555 end Print; 556 557 -- Start of processing for Put_Line 558 559 begin 560 if Traceback = null then 561 declare 562 Len : Natural; 563 Start : Natural; 564 Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); 565 566 begin 567 Call_Chain (Trace, Len); 568 Skip_Levels 569 (Depth => Depth, 570 Trace => Trace, 571 Start => Start, 572 Len => Len, 573 Ignored_Frame_Start => Ignored_Frame_Start, 574 Ignored_Frame_End => Ignored_Frame_End); 575 Print (Trace (Start .. Len)); 576 end; 577 578 else 579 Print (Traceback.all); 580 end if; 581 end Put_Line; 582 583 ----------------- 584 -- Skip_Levels -- 585 ----------------- 586 587 procedure Skip_Levels 588 (Depth : Natural; 589 Trace : Tracebacks_Array; 590 Start : out Natural; 591 Len : in out Natural; 592 Ignored_Frame_Start : System.Address; 593 Ignored_Frame_End : System.Address) 594 is 595 begin 596 Start := Trace'First; 597 598 while Start <= Len 599 and then (PC_For (Trace (Start)) < Ignored_Frame_Start 600 or else PC_For (Trace (Start)) > Ignored_Frame_End) 601 loop 602 Start := Start + 1; 603 end loop; 604 605 Start := Start + 1; 606 607 -- Just in case: make sure we have a traceback even if Ignore_Till 608 -- wasn't found. 609 610 if Start > Len then 611 Start := 1; 612 end if; 613 614 if Len - Start + 1 > Depth then 615 Len := Depth + Start - 1; 616 end if; 617 end Skip_Levels; 618 619 ------------------------------ 620 -- Find_Or_Create_Traceback -- 621 ------------------------------ 622 623 function Find_Or_Create_Traceback 624 (Pool : Debug_Pool; 625 Kind : Traceback_Kind; 626 Size : Storage_Count; 627 Ignored_Frame_Start : System.Address; 628 Ignored_Frame_End : System.Address) return Traceback_Htable_Elem_Ptr 629 is 630 begin 631 if Pool.Stack_Trace_Depth = 0 then 632 return null; 633 end if; 634 635 declare 636 Disable_Exit_Value : constant Boolean := Disable; 637 638 Elem : Traceback_Htable_Elem_Ptr; 639 Len : Natural; 640 Start : Natural; 641 Trace : aliased Tracebacks_Array 642 (1 .. Integer (Pool.Stack_Trace_Depth) + 643 Max_Ignored_Levels); 644 645 begin 646 Disable := True; 647 Call_Chain (Trace, Len); 648 Skip_Levels 649 (Depth => Pool.Stack_Trace_Depth, 650 Trace => Trace, 651 Start => Start, 652 Len => Len, 653 Ignored_Frame_Start => Ignored_Frame_Start, 654 Ignored_Frame_End => Ignored_Frame_End); 655 656 -- Check if the traceback is already in the table 657 658 Elem := 659 Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access); 660 661 -- If not, insert it 662 663 if Elem = null then 664 Elem := 665 new Traceback_Htable_Elem' 666 (Traceback => 667 new Tracebacks_Array'(Trace (Start .. Len)), 668 Count => 1, 669 Kind => Kind, 670 Total => Byte_Count (Size), 671 Frees => 0, 672 Total_Frees => 0, 673 Next => null); 674 Traceback_Count := Traceback_Count + 1; 675 Backtrace_Htable.Set (Elem); 676 677 else 678 Elem.Count := Elem.Count + 1; 679 Elem.Total := Elem.Total + Byte_Count (Size); 680 end if; 681 682 Disable := Disable_Exit_Value; 683 return Elem; 684 exception 685 when others => 686 Disable := Disable_Exit_Value; 687 raise; 688 end; 689 end Find_Or_Create_Traceback; 690 691 -------------- 692 -- Validity -- 693 -------------- 694 695 package body Validity is 696 697 -- The validity bits of the allocated blocks are kept in a has table. 698 -- Each component of the hash table contains the validity bits for a 699 -- 16 Mbyte memory chunk. 700 701 -- The reason the validity bits are kept for chunks of memory rather 702 -- than in a big array is that on some 64 bit platforms, it may happen 703 -- that two chunk of allocated data are very far from each other. 704 705 Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB 706 Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; 707 708 Max_Validity_Byte_Index : constant := 709 Memory_Chunk_Size / Validity_Divisor; 710 711 subtype Validity_Byte_Index is 712 Integer_Address range 0 .. Max_Validity_Byte_Index - 1; 713 714 type Byte is mod 2 ** System.Storage_Unit; 715 716 type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; 717 type Validity_Bits_Part_Ref is access all Validity_Bits_Part; 718 No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; 719 720 type Validity_Bits is record 721 Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; 722 -- True if chunk of memory at this address is currently allocated 723 724 Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; 725 -- True if chunk of memory at this address was allocated once after 726 -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate 727 -- if chunk of memory should be handled a block allocated by this 728 -- package. 729 730 end record; 731 732 type Validity_Bits_Ref is access all Validity_Bits; 733 No_Validity_Bits : constant Validity_Bits_Ref := null; 734 735 Max_Header_Num : constant := 1023; 736 737 type Header_Num is range 0 .. Max_Header_Num - 1; 738 739 function Hash (F : Integer_Address) return Header_Num; 740 741 function Is_Valid_Or_Handled 742 (Storage : System.Address; 743 Valid : Boolean) return Boolean; 744 pragma Inline (Is_Valid_Or_Handled); 745 -- Internal implementation of Is_Valid and Is_Handled. 746 -- Valid is used to select Valid or Handled arrays. 747 748 package Validy_Htable is new GNAT.HTable.Simple_HTable 749 (Header_Num => Header_Num, 750 Element => Validity_Bits_Ref, 751 No_Element => No_Validity_Bits, 752 Key => Integer_Address, 753 Hash => Hash, 754 Equal => "="); 755 -- Table to keep the validity and handled bit blocks for the allocated 756 -- data. 757 758 function To_Pointer is new Ada.Unchecked_Conversion 759 (System.Address, Validity_Bits_Part_Ref); 760 761 procedure Memset (A : Address; C : Integer; N : size_t); 762 pragma Import (C, Memset, "memset"); 763 764 ---------- 765 -- Hash -- 766 ---------- 767 768 function Hash (F : Integer_Address) return Header_Num is 769 begin 770 return Header_Num (F mod Max_Header_Num); 771 end Hash; 772 773 ------------------------- 774 -- Is_Valid_Or_Handled -- 775 ------------------------- 776 777 function Is_Valid_Or_Handled 778 (Storage : System.Address; 779 Valid : Boolean) return Boolean is 780 Int_Storage : constant Integer_Address := To_Integer (Storage); 781 782 begin 783 -- The pool only returns addresses aligned on Storage_Alignment so 784 -- anything off cannot be a valid block address and we can return 785 -- early in this case. We actually have to since our data structures 786 -- map validity bits for such aligned addresses only. 787 788 if Int_Storage mod Storage_Alignment /= 0 then 789 return False; 790 end if; 791 792 declare 793 Block_Number : constant Integer_Address := 794 Int_Storage / Memory_Chunk_Size; 795 Ptr : constant Validity_Bits_Ref := 796 Validy_Htable.Get (Block_Number); 797 Offset : constant Integer_Address := 798 (Int_Storage - 799 (Block_Number * Memory_Chunk_Size)) / 800 Storage_Alignment; 801 Bit : constant Byte := 802 2 ** Natural (Offset mod System.Storage_Unit); 803 begin 804 if Ptr = No_Validity_Bits then 805 return False; 806 else 807 if Valid then 808 return (Ptr.Valid (Offset / System.Storage_Unit) 809 and Bit) /= 0; 810 else 811 if Ptr.Handled = No_Validity_Bits_Part then 812 return False; 813 else 814 return (Ptr.Handled (Offset / System.Storage_Unit) 815 and Bit) /= 0; 816 end if; 817 end if; 818 end if; 819 end; 820 end Is_Valid_Or_Handled; 821 822 -------------- 823 -- Is_Valid -- 824 -------------- 825 826 function Is_Valid (Storage : System.Address) return Boolean is 827 begin 828 return Is_Valid_Or_Handled (Storage => Storage, Valid => True); 829 end Is_Valid; 830 831 ----------------- 832 -- Is_Handled -- 833 ----------------- 834 835 function Is_Handled (Storage : System.Address) return Boolean is 836 begin 837 return Is_Valid_Or_Handled (Storage => Storage, Valid => False); 838 end Is_Handled; 839 840 --------------- 841 -- Set_Valid -- 842 --------------- 843 844 procedure Set_Valid (Storage : System.Address; Value : Boolean) is 845 Int_Storage : constant Integer_Address := To_Integer (Storage); 846 Block_Number : constant Integer_Address := 847 Int_Storage / Memory_Chunk_Size; 848 Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); 849 Offset : constant Integer_Address := 850 (Int_Storage - (Block_Number * Memory_Chunk_Size)) / 851 Storage_Alignment; 852 Bit : constant Byte := 853 2 ** Natural (Offset mod System.Storage_Unit); 854 855 procedure Set_Handled; 856 pragma Inline (Set_Handled); 857 -- if Allow_Unhandled_Memory set Handled bit in table. 858 859 ----------------- 860 -- Set_Handled -- 861 ----------------- 862 863 procedure Set_Handled is 864 begin 865 if Allow_Unhandled_Memory then 866 if Ptr.Handled = No_Validity_Bits_Part then 867 Ptr.Handled := 868 To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); 869 Memset 870 (A => Ptr.Handled.all'Address, 871 C => 0, 872 N => size_t (Max_Validity_Byte_Index)); 873 end if; 874 875 Ptr.Handled (Offset / System.Storage_Unit) := 876 Ptr.Handled (Offset / System.Storage_Unit) or Bit; 877 end if; 878 end Set_Handled; 879 880 -- Start of processing for Set_Valid 881 882 begin 883 if Ptr = No_Validity_Bits then 884 885 -- First time in this memory area: allocate a new block and put 886 -- it in the table. 887 888 if Value then 889 Ptr := new Validity_Bits; 890 Validity_Count := Validity_Count + 1; 891 Ptr.Valid := 892 To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); 893 Validy_Htable.Set (Block_Number, Ptr); 894 Memset 895 (A => Ptr.Valid.all'Address, 896 C => 0, 897 N => size_t (Max_Validity_Byte_Index)); 898 Ptr.Valid (Offset / System.Storage_Unit) := Bit; 899 Set_Handled; 900 end if; 901 902 else 903 if Value then 904 Ptr.Valid (Offset / System.Storage_Unit) := 905 Ptr.Valid (Offset / System.Storage_Unit) or Bit; 906 Set_Handled; 907 else 908 Ptr.Valid (Offset / System.Storage_Unit) := 909 Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); 910 end if; 911 end if; 912 end Set_Valid; 913 end Validity; 914 915 -------------- 916 -- Allocate -- 917 -------------- 918 919 procedure Allocate 920 (Pool : in out Debug_Pool; 921 Storage_Address : out Address; 922 Size_In_Storage_Elements : Storage_Count; 923 Alignment : Storage_Count) 924 is 925 pragma Unreferenced (Alignment); 926 -- Ignored, we always force Storage_Alignment 927 928 type Local_Storage_Array is new Storage_Array 929 (1 .. Size_In_Storage_Elements + Extra_Allocation); 930 931 type Ptr is access Local_Storage_Array; 932 -- On some systems, we might want to physically protect pages against 933 -- writing when they have been freed (of course, this is expensive in 934 -- terms of wasted memory). To do that, all we should have to do it to 935 -- set the size of this array to the page size. See mprotect(). 936 937 Current : Byte_Count; 938 P : Ptr; 939 Trace : Traceback_Htable_Elem_Ptr; 940 941 Reset_Disable_At_Exit : Boolean := False; 942 943 Lock : Scope_Lock; 944 pragma Unreferenced (Lock); 945 946 begin 947 <<Allocate_Label>> 948 949 if Disable then 950 Storage_Address := 951 System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); 952 return; 953 end if; 954 955 Reset_Disable_At_Exit := True; 956 Disable := True; 957 958 Pool.Alloc_Count := Pool.Alloc_Count + 1; 959 960 -- If necessary, start physically releasing memory. The reason this is 961 -- done here, although Pool.Logically_Deallocated has not changed above, 962 -- is so that we do this only after a series of deallocations (e.g loop 963 -- that deallocates a big array). If we were doing that in Deallocate, 964 -- we might be physically freeing memory several times during the loop, 965 -- which is expensive. 966 967 if Pool.Logically_Deallocated > 968 Byte_Count (Pool.Maximum_Logically_Freed_Memory) 969 then 970 Free_Physically (Pool); 971 end if; 972 973 -- Use standard (i.e. through malloc) allocations. This automatically 974 -- raises Storage_Error if needed. We also try once more to physically 975 -- release memory, so that even marked blocks, in the advanced scanning, 976 -- are freed. Note that we do not initialize the storage array since it 977 -- is not necessary to do so (however this will cause bogus valgrind 978 -- warnings, which should simply be ignored). 979 980 begin 981 P := new Local_Storage_Array; 982 983 exception 984 when Storage_Error => 985 Free_Physically (Pool); 986 P := new Local_Storage_Array; 987 end; 988 989 -- Compute Storage_Address, aimed at receiving user data. We need room 990 -- for the allocation header just ahead of the user data space plus 991 -- alignment padding so Storage_Address is aligned on Storage_Alignment, 992 -- like so: 993 -- 994 -- Storage_Address, aligned 995 -- on Storage_Alignment 996 -- v 997 -- | ~~~~ | Header | User data ... | 998 -- ^........^ 999 -- Header_Offset 1000 -- 1001 -- Header_Offset is fixed so moving back and forth between user data 1002 -- and allocation header is straightforward. The value is also such 1003 -- that the header type alignment is honored when starting from 1004 -- Default_alignment. 1005 1006 -- For the purpose of computing Storage_Address, we just do as if the 1007 -- header was located first, followed by the alignment padding: 1008 1009 Storage_Address := 1010 To_Address (Align (To_Integer (P.all'Address) + 1011 Integer_Address (Header_Offset))); 1012 -- Computation is done in Integer_Address, not Storage_Offset, because 1013 -- the range of Storage_Offset may not be large enough. 1014 1015 pragma Assert ((Storage_Address - System.Null_Address) 1016 mod Storage_Alignment = 0); 1017 pragma Assert (Storage_Address + Size_In_Storage_Elements 1018 <= P.all'Address + P'Length); 1019 1020 Trace := 1021 Find_Or_Create_Traceback 1022 (Pool => Pool, 1023 Kind => Alloc, 1024 Size => Size_In_Storage_Elements, 1025 Ignored_Frame_Start => Allocate_Label'Address, 1026 Ignored_Frame_End => Code_Address_For_Allocate_End); 1027 1028 pragma Warnings (Off); 1029 -- Turn warning on alignment for convert call off. We know that in fact 1030 -- this conversion is safe since P itself is always aligned on 1031 -- Storage_Alignment. 1032 1033 Header_Of (Storage_Address).all := 1034 (Allocation_Address => P.all'Address, 1035 Alloc_Traceback => Trace, 1036 Dealloc_Traceback => To_Traceback (null), 1037 Next => Pool.First_Used_Block, 1038 Block_Size => Size_In_Storage_Elements); 1039 1040 pragma Warnings (On); 1041 1042 -- Link this block in the list of used blocks. This will be used to list 1043 -- memory leaks in Print_Info, and for the advanced schemes of 1044 -- Physical_Free, where we want to traverse all allocated blocks and 1045 -- search for possible references. 1046 1047 -- We insert in front, since most likely we'll be freeing the most 1048 -- recently allocated blocks first (the older one might stay allocated 1049 -- for the whole life of the application). 1050 1051 if Pool.First_Used_Block /= System.Null_Address then 1052 Header_Of (Pool.First_Used_Block).Dealloc_Traceback := 1053 To_Address (Storage_Address); 1054 end if; 1055 1056 Pool.First_Used_Block := Storage_Address; 1057 1058 -- Mark the new address as valid 1059 1060 Set_Valid (Storage_Address, True); 1061 1062 if Pool.Low_Level_Traces then 1063 Put (Output_File (Pool), 1064 "info: Allocated" 1065 & Storage_Count'Image (Size_In_Storage_Elements) 1066 & " bytes at "); 1067 Print_Address (Output_File (Pool), Storage_Address); 1068 Put (Output_File (Pool), 1069 " (physically:" 1070 & Storage_Count'Image (Local_Storage_Array'Length) 1071 & " bytes at "); 1072 Print_Address (Output_File (Pool), P.all'Address); 1073 Put (Output_File (Pool), 1074 "), at "); 1075 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1076 Allocate_Label'Address, 1077 Code_Address_For_Deallocate_End); 1078 end if; 1079 1080 -- Update internal data 1081 1082 Pool.Allocated := 1083 Pool.Allocated + Byte_Count (Size_In_Storage_Elements); 1084 1085 Current := Pool.Current_Water_Mark; 1086 1087 if Current > Pool.High_Water then 1088 Pool.High_Water := Current; 1089 end if; 1090 1091 Disable := False; 1092 1093 exception 1094 when others => 1095 if Reset_Disable_At_Exit then 1096 Disable := False; 1097 end if; 1098 raise; 1099 end Allocate; 1100 1101 ------------------ 1102 -- Allocate_End -- 1103 ------------------ 1104 1105 -- DO NOT MOVE, this must be right after Allocate. This is similar to what 1106 -- is done in a-except, so that we can hide the traceback frames internal 1107 -- to this package 1108 1109 procedure Allocate_End is 1110 begin 1111 <<Allocate_End_Label>> 1112 Code_Address_For_Allocate_End := Allocate_End_Label'Address; 1113 end Allocate_End; 1114 1115 ------------------- 1116 -- Set_Dead_Beef -- 1117 ------------------- 1118 1119 procedure Set_Dead_Beef 1120 (Storage_Address : System.Address; 1121 Size_In_Storage_Elements : Storage_Count) 1122 is 1123 Dead_Bytes : constant := 4; 1124 1125 type Data is mod 2 ** (Dead_Bytes * 8); 1126 for Data'Size use Dead_Bytes * 8; 1127 1128 Dead : constant Data := 16#DEAD_BEEF#; 1129 1130 type Dead_Memory is array 1131 (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data; 1132 type Mem_Ptr is access Dead_Memory; 1133 1134 type Byte is mod 2 ** 8; 1135 for Byte'Size use 8; 1136 1137 type Dead_Memory_Bytes is array (0 .. 2) of Byte; 1138 type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes; 1139 1140 function From_Ptr is new Ada.Unchecked_Conversion 1141 (System.Address, Mem_Ptr); 1142 1143 function From_Ptr is new Ada.Unchecked_Conversion 1144 (System.Address, Dead_Memory_Bytes_Ptr); 1145 1146 M : constant Mem_Ptr := From_Ptr (Storage_Address); 1147 M2 : Dead_Memory_Bytes_Ptr; 1148 Modulo : constant Storage_Count := 1149 Size_In_Storage_Elements mod Dead_Bytes; 1150 begin 1151 M.all := (others => Dead); 1152 1153 -- Any bytes left (up to three of them) 1154 1155 if Modulo /= 0 then 1156 M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes); 1157 1158 M2 (0) := 16#DE#; 1159 if Modulo >= 2 then 1160 M2 (1) := 16#AD#; 1161 1162 if Modulo >= 3 then 1163 M2 (2) := 16#BE#; 1164 end if; 1165 end if; 1166 end if; 1167 end Set_Dead_Beef; 1168 1169 --------------------- 1170 -- Free_Physically -- 1171 --------------------- 1172 1173 procedure Free_Physically (Pool : in out Debug_Pool) is 1174 type Byte is mod 256; 1175 type Byte_Access is access Byte; 1176 1177 function To_Byte is new Ada.Unchecked_Conversion 1178 (System.Address, Byte_Access); 1179 1180 type Address_Access is access System.Address; 1181 1182 function To_Address_Access is new Ada.Unchecked_Conversion 1183 (System.Address, Address_Access); 1184 1185 In_Use_Mark : constant Byte := 16#D#; 1186 Free_Mark : constant Byte := 16#F#; 1187 1188 Total_Freed : Storage_Count := 0; 1189 1190 procedure Reset_Marks; 1191 -- Unmark all the logically freed blocks, so that they are considered 1192 -- for physical deallocation 1193 1194 procedure Mark 1195 (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean); 1196 -- Mark the user data block starting at A. For a block of size zero, 1197 -- nothing is done. For a block with a different size, the first byte 1198 -- is set to either "D" (in use) or "F" (free). 1199 1200 function Marked (A : System.Address) return Boolean; 1201 -- Return true if the user data block starting at A might be in use 1202 -- somewhere else 1203 1204 procedure Mark_Blocks; 1205 -- Traverse all allocated blocks, and search for possible references 1206 -- to logically freed blocks. Mark them appropriately 1207 1208 procedure Free_Blocks (Ignore_Marks : Boolean); 1209 -- Physically release blocks. Only the blocks that haven't been marked 1210 -- will be released, unless Ignore_Marks is true. 1211 1212 ----------------- 1213 -- Free_Blocks -- 1214 ----------------- 1215 1216 procedure Free_Blocks (Ignore_Marks : Boolean) is 1217 Header : Allocation_Header_Access; 1218 Tmp : System.Address := Pool.First_Free_Block; 1219 Next : System.Address; 1220 Previous : System.Address := System.Null_Address; 1221 1222 begin 1223 while Tmp /= System.Null_Address 1224 and then 1225 not (Total_Freed > Pool.Minimum_To_Free 1226 and Pool.Logically_Deallocated < 1227 Byte_Count (Pool.Maximum_Logically_Freed_Memory)) 1228 loop 1229 Header := Header_Of (Tmp); 1230 1231 -- If we know, or at least assume, the block is no longer 1232 -- referenced anywhere, we can free it physically. 1233 1234 if Ignore_Marks or else not Marked (Tmp) then 1235 declare 1236 pragma Suppress (All_Checks); 1237 -- Suppress the checks on this section. If they are overflow 1238 -- errors, it isn't critical, and we'd rather avoid a 1239 -- Constraint_Error in that case. 1240 1241 begin 1242 -- Note that block_size < zero for freed blocks 1243 1244 Pool.Physically_Deallocated := 1245 Pool.Physically_Deallocated - 1246 Byte_Count (Header.Block_Size); 1247 1248 Pool.Logically_Deallocated := 1249 Pool.Logically_Deallocated + 1250 Byte_Count (Header.Block_Size); 1251 1252 Total_Freed := Total_Freed - Header.Block_Size; 1253 end; 1254 1255 Next := Header.Next; 1256 1257 if Pool.Low_Level_Traces then 1258 Put 1259 (Output_File (Pool), 1260 "info: Freeing physical memory " 1261 & Storage_Count'Image 1262 ((abs Header.Block_Size) + Extra_Allocation) 1263 & " bytes at "); 1264 Print_Address (Output_File (Pool), 1265 Header.Allocation_Address); 1266 Put_Line (Output_File (Pool), ""); 1267 end if; 1268 1269 if System_Memory_Debug_Pool_Enabled then 1270 System.CRTL.free (Header.Allocation_Address); 1271 else 1272 System.Memory.Free (Header.Allocation_Address); 1273 end if; 1274 1275 Set_Valid (Tmp, False); 1276 1277 -- Remove this block from the list 1278 1279 if Previous = System.Null_Address then 1280 Pool.First_Free_Block := Next; 1281 else 1282 Header_Of (Previous).Next := Next; 1283 end if; 1284 1285 Tmp := Next; 1286 1287 else 1288 Previous := Tmp; 1289 Tmp := Header.Next; 1290 end if; 1291 end loop; 1292 end Free_Blocks; 1293 1294 ---------- 1295 -- Mark -- 1296 ---------- 1297 1298 procedure Mark 1299 (H : Allocation_Header_Access; 1300 A : System.Address; 1301 In_Use : Boolean) 1302 is 1303 begin 1304 if H.Block_Size /= 0 then 1305 To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); 1306 end if; 1307 end Mark; 1308 1309 ----------------- 1310 -- Mark_Blocks -- 1311 ----------------- 1312 1313 procedure Mark_Blocks is 1314 Tmp : System.Address := Pool.First_Used_Block; 1315 Previous : System.Address; 1316 Last : System.Address; 1317 Pointed : System.Address; 1318 Header : Allocation_Header_Access; 1319 1320 begin 1321 -- For each allocated block, check its contents. Things that look 1322 -- like a possible address are used to mark the blocks so that we try 1323 -- and keep them, for better detection in case of invalid access. 1324 -- This mechanism is far from being fool-proof: it doesn't check the 1325 -- stacks of the threads, doesn't check possible memory allocated not 1326 -- under control of this debug pool. But it should allow us to catch 1327 -- more cases. 1328 1329 while Tmp /= System.Null_Address loop 1330 Previous := Tmp; 1331 Last := Tmp + Header_Of (Tmp).Block_Size; 1332 while Previous < Last loop 1333 -- ??? Should we move byte-per-byte, or consider that addresses 1334 -- are always aligned on 4-bytes boundaries ? Let's use the 1335 -- fastest for now. 1336 1337 Pointed := To_Address_Access (Previous).all; 1338 if Is_Valid (Pointed) then 1339 Header := Header_Of (Pointed); 1340 1341 -- Do not even attempt to mark blocks in use. That would 1342 -- screw up the whole application, of course. 1343 1344 if Header.Block_Size < 0 then 1345 Mark (Header, Pointed, In_Use => True); 1346 end if; 1347 end if; 1348 1349 Previous := Previous + System.Address'Size; 1350 end loop; 1351 1352 Tmp := Header_Of (Tmp).Next; 1353 end loop; 1354 end Mark_Blocks; 1355 1356 ------------ 1357 -- Marked -- 1358 ------------ 1359 1360 function Marked (A : System.Address) return Boolean is 1361 begin 1362 return To_Byte (A).all = In_Use_Mark; 1363 end Marked; 1364 1365 ----------------- 1366 -- Reset_Marks -- 1367 ----------------- 1368 1369 procedure Reset_Marks is 1370 Current : System.Address := Pool.First_Free_Block; 1371 Header : Allocation_Header_Access; 1372 1373 begin 1374 while Current /= System.Null_Address loop 1375 Header := Header_Of (Current); 1376 Mark (Header, Current, False); 1377 Current := Header.Next; 1378 end loop; 1379 end Reset_Marks; 1380 1381 Lock : Scope_Lock; 1382 pragma Unreferenced (Lock); 1383 1384 -- Start of processing for Free_Physically 1385 1386 begin 1387 if Pool.Advanced_Scanning then 1388 1389 -- Reset the mark for each freed block 1390 1391 Reset_Marks; 1392 1393 Mark_Blocks; 1394 end if; 1395 1396 Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning); 1397 1398 -- The contract is that we need to free at least Minimum_To_Free bytes, 1399 -- even if this means freeing marked blocks in the advanced scheme. 1400 1401 if Total_Freed < Pool.Minimum_To_Free 1402 and then Pool.Advanced_Scanning 1403 then 1404 Pool.Marked_Blocks_Deallocated := True; 1405 Free_Blocks (Ignore_Marks => True); 1406 end if; 1407 end Free_Physically; 1408 1409 -------------- 1410 -- Get_Size -- 1411 -------------- 1412 1413 procedure Get_Size 1414 (Storage_Address : Address; 1415 Size_In_Storage_Elements : out Storage_Count; 1416 Valid : out Boolean) 1417 is 1418 Lock : Scope_Lock; 1419 pragma Unreferenced (Lock); 1420 1421 begin 1422 Valid := Is_Valid (Storage_Address); 1423 Size_In_Storage_Elements := Storage_Count'First; 1424 1425 if Is_Valid (Storage_Address) then 1426 declare 1427 Header : constant Allocation_Header_Access := 1428 Header_Of (Storage_Address); 1429 1430 begin 1431 if Header.Block_Size >= 0 then 1432 Valid := True; 1433 Size_In_Storage_Elements := Header.Block_Size; 1434 else 1435 Valid := False; 1436 end if; 1437 end; 1438 else 1439 Valid := False; 1440 end if; 1441 end Get_Size; 1442 1443 --------------------- 1444 -- Print_Traceback -- 1445 --------------------- 1446 1447 procedure Print_Traceback 1448 (Output_File : File_Type; 1449 Prefix : String; 1450 Traceback : Traceback_Htable_Elem_Ptr) 1451 is 1452 begin 1453 if Traceback /= null then 1454 Put (Output_File, Prefix); 1455 Put_Line (Output_File, 0, Traceback.Traceback); 1456 end if; 1457 end Print_Traceback; 1458 1459 ---------------- 1460 -- Deallocate -- 1461 ---------------- 1462 1463 procedure Deallocate 1464 (Pool : in out Debug_Pool; 1465 Storage_Address : Address; 1466 Size_In_Storage_Elements : Storage_Count; 1467 Alignment : Storage_Count) 1468 is 1469 pragma Unreferenced (Alignment); 1470 1471 Header : constant Allocation_Header_Access := 1472 Header_Of (Storage_Address); 1473 Previous : System.Address; 1474 Valid : Boolean; 1475 1476 Header_Block_Size_Was_Less_Than_0 : Boolean := True; 1477 1478 begin 1479 <<Deallocate_Label>> 1480 1481 declare 1482 Lock : Scope_Lock; 1483 pragma Unreferenced (Lock); 1484 1485 begin 1486 Valid := Is_Valid (Storage_Address); 1487 1488 if Valid and then not (Header.Block_Size < 0) then 1489 Header_Block_Size_Was_Less_Than_0 := False; 1490 1491 -- Some sort of codegen problem or heap corruption caused the 1492 -- Size_In_Storage_Elements to be wrongly computed. The code 1493 -- below is all based on the assumption that Header.all is not 1494 -- corrupted, such that the error is non-fatal. 1495 1496 if Header.Block_Size /= Size_In_Storage_Elements and then 1497 Size_In_Storage_Elements /= Storage_Count'Last 1498 then 1499 Put_Line (Output_File (Pool), 1500 "error: Deallocate size " 1501 & Storage_Count'Image (Size_In_Storage_Elements) 1502 & " does not match allocate size " 1503 & Storage_Count'Image (Header.Block_Size)); 1504 end if; 1505 1506 if Pool.Low_Level_Traces then 1507 Put (Output_File (Pool), 1508 "info: Deallocated" 1509 & Storage_Count'Image (Header.Block_Size) 1510 & " bytes at "); 1511 Print_Address (Output_File (Pool), Storage_Address); 1512 Put (Output_File (Pool), 1513 " (physically" 1514 & Storage_Count'Image 1515 (Header.Block_Size + Extra_Allocation) 1516 & " bytes at "); 1517 Print_Address (Output_File (Pool), Header.Allocation_Address); 1518 Put (Output_File (Pool), "), at "); 1519 1520 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1521 Deallocate_Label'Address, 1522 Code_Address_For_Deallocate_End); 1523 Print_Traceback (Output_File (Pool), 1524 " Memory was allocated at ", 1525 Header.Alloc_Traceback); 1526 end if; 1527 1528 -- Remove this block from the list of used blocks 1529 1530 Previous := 1531 To_Address (Header.Dealloc_Traceback); 1532 1533 if Previous = System.Null_Address then 1534 Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; 1535 1536 if Pool.First_Used_Block /= System.Null_Address then 1537 Header_Of (Pool.First_Used_Block).Dealloc_Traceback := 1538 To_Traceback (null); 1539 end if; 1540 1541 else 1542 Header_Of (Previous).Next := Header.Next; 1543 1544 if Header.Next /= System.Null_Address then 1545 Header_Of 1546 (Header.Next).Dealloc_Traceback := To_Address (Previous); 1547 end if; 1548 end if; 1549 1550 -- Update the Alloc_Traceback Frees/Total_Frees members 1551 -- (if present) 1552 1553 if Header.Alloc_Traceback /= null then 1554 Header.Alloc_Traceback.Frees := 1555 Header.Alloc_Traceback.Frees + 1; 1556 Header.Alloc_Traceback.Total_Frees := 1557 Header.Alloc_Traceback.Total_Frees + 1558 Byte_Count (Header.Block_Size); 1559 end if; 1560 1561 Pool.Free_Count := Pool.Free_Count + 1; 1562 1563 -- Update the header 1564 1565 Header.all := 1566 (Allocation_Address => Header.Allocation_Address, 1567 Alloc_Traceback => Header.Alloc_Traceback, 1568 Dealloc_Traceback => To_Traceback 1569 (Find_Or_Create_Traceback 1570 (Pool, Dealloc, 1571 Header.Block_Size, 1572 Deallocate_Label'Address, 1573 Code_Address_For_Deallocate_End)), 1574 Next => System.Null_Address, 1575 Block_Size => -Header.Block_Size); 1576 1577 if Pool.Reset_Content_On_Free then 1578 Set_Dead_Beef (Storage_Address, -Header.Block_Size); 1579 end if; 1580 1581 Pool.Logically_Deallocated := 1582 Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); 1583 1584 -- Link this free block with the others (at the end of the list, 1585 -- so that we can start releasing the older blocks first later on) 1586 1587 if Pool.First_Free_Block = System.Null_Address then 1588 Pool.First_Free_Block := Storage_Address; 1589 Pool.Last_Free_Block := Storage_Address; 1590 1591 else 1592 Header_Of (Pool.Last_Free_Block).Next := Storage_Address; 1593 Pool.Last_Free_Block := Storage_Address; 1594 end if; 1595 1596 -- Do not physically release the memory here, but in Alloc. 1597 -- See comment there for details. 1598 end if; 1599 end; 1600 1601 if not Valid then 1602 if Storage_Address = System.Null_Address then 1603 if Pool.Raise_Exceptions and then 1604 Size_In_Storage_Elements /= Storage_Count'Last 1605 then 1606 raise Freeing_Not_Allocated_Storage; 1607 else 1608 Put (Output_File (Pool), 1609 "error: Freeing Null_Address, at "); 1610 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1611 Deallocate_Label'Address, 1612 Code_Address_For_Deallocate_End); 1613 return; 1614 end if; 1615 end if; 1616 1617 if Allow_Unhandled_Memory 1618 and then not Is_Handled (Storage_Address) 1619 then 1620 System.CRTL.free (Storage_Address); 1621 return; 1622 end if; 1623 1624 if Pool.Raise_Exceptions 1625 and then Size_In_Storage_Elements /= Storage_Count'Last 1626 then 1627 raise Freeing_Not_Allocated_Storage; 1628 else 1629 Put (Output_File (Pool), 1630 "error: Freeing not allocated storage, at "); 1631 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1632 Deallocate_Label'Address, 1633 Code_Address_For_Deallocate_End); 1634 end if; 1635 1636 elsif Header_Block_Size_Was_Less_Than_0 then 1637 if Pool.Raise_Exceptions then 1638 raise Freeing_Deallocated_Storage; 1639 else 1640 Put (Output_File (Pool), 1641 "error: Freeing already deallocated storage, at "); 1642 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1643 Deallocate_Label'Address, 1644 Code_Address_For_Deallocate_End); 1645 Print_Traceback (Output_File (Pool), 1646 " Memory already deallocated at ", 1647 To_Traceback (Header.Dealloc_Traceback)); 1648 Print_Traceback (Output_File (Pool), " Memory was allocated at ", 1649 Header.Alloc_Traceback); 1650 end if; 1651 end if; 1652 end Deallocate; 1653 1654 -------------------- 1655 -- Deallocate_End -- 1656 -------------------- 1657 1658 -- DO NOT MOVE, this must be right after Deallocate 1659 1660 -- See Allocate_End 1661 1662 -- This is making assumptions about code order that may be invalid ??? 1663 1664 procedure Deallocate_End is 1665 begin 1666 <<Deallocate_End_Label>> 1667 Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; 1668 end Deallocate_End; 1669 1670 ----------------- 1671 -- Dereference -- 1672 ----------------- 1673 1674 procedure Dereference 1675 (Pool : in out Debug_Pool; 1676 Storage_Address : Address; 1677 Size_In_Storage_Elements : Storage_Count; 1678 Alignment : Storage_Count) 1679 is 1680 pragma Unreferenced (Alignment, Size_In_Storage_Elements); 1681 1682 Valid : constant Boolean := Is_Valid (Storage_Address); 1683 Header : Allocation_Header_Access; 1684 1685 begin 1686 -- Locking policy: we do not do any locking in this procedure. The 1687 -- tables are only read, not written to, and although a problem might 1688 -- appear if someone else is modifying the tables at the same time, this 1689 -- race condition is not intended to be detected by this storage_pool (a 1690 -- now invalid pointer would appear as valid). Instead, we prefer 1691 -- optimum performance for dereferences. 1692 1693 <<Dereference_Label>> 1694 1695 if not Valid then 1696 if Pool.Raise_Exceptions then 1697 raise Accessing_Not_Allocated_Storage; 1698 else 1699 Put (Output_File (Pool), 1700 "error: Accessing not allocated storage, at "); 1701 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1702 Dereference_Label'Address, 1703 Code_Address_For_Dereference_End); 1704 end if; 1705 1706 else 1707 Header := Header_Of (Storage_Address); 1708 1709 if Header.Block_Size < 0 then 1710 if Pool.Raise_Exceptions then 1711 raise Accessing_Deallocated_Storage; 1712 else 1713 Put (Output_File (Pool), 1714 "error: Accessing deallocated storage, at "); 1715 Put_Line 1716 (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1717 Dereference_Label'Address, 1718 Code_Address_For_Dereference_End); 1719 Print_Traceback (Output_File (Pool), " First deallocation at ", 1720 To_Traceback (Header.Dealloc_Traceback)); 1721 Print_Traceback (Output_File (Pool), " Initial allocation at ", 1722 Header.Alloc_Traceback); 1723 end if; 1724 end if; 1725 end if; 1726 end Dereference; 1727 1728 --------------------- 1729 -- Dereference_End -- 1730 --------------------- 1731 1732 -- DO NOT MOVE: this must be right after Dereference 1733 1734 -- See Allocate_End 1735 1736 -- This is making assumptions about code order that may be invalid ??? 1737 1738 procedure Dereference_End is 1739 begin 1740 <<Dereference_End_Label>> 1741 Code_Address_For_Dereference_End := Dereference_End_Label'Address; 1742 end Dereference_End; 1743 1744 ---------------- 1745 -- Print_Info -- 1746 ---------------- 1747 1748 procedure Print_Info 1749 (Pool : Debug_Pool; 1750 Cumulate : Boolean := False; 1751 Display_Slots : Boolean := False; 1752 Display_Leaks : Boolean := False) 1753 is 1754 package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable 1755 (Header_Num => Header, 1756 Element => Traceback_Htable_Elem, 1757 Elmt_Ptr => Traceback_Htable_Elem_Ptr, 1758 Null_Ptr => null, 1759 Set_Next => Set_Next, 1760 Next => Next, 1761 Key => Tracebacks_Array_Access, 1762 Get_Key => Get_Key, 1763 Hash => Hash, 1764 Equal => Equal); 1765 -- This needs a comment ??? probably some of the ones below do too??? 1766 1767 Current : System.Address; 1768 Data : Traceback_Htable_Elem_Ptr; 1769 Elem : Traceback_Htable_Elem_Ptr; 1770 Header : Allocation_Header_Access; 1771 K : Traceback_Kind; 1772 1773 begin 1774 Put_Line 1775 ("Total allocated bytes : " & 1776 Byte_Count'Image (Pool.Allocated)); 1777 1778 Put_Line 1779 ("Total logically deallocated bytes : " & 1780 Byte_Count'Image (Pool.Logically_Deallocated)); 1781 1782 Put_Line 1783 ("Total physically deallocated bytes : " & 1784 Byte_Count'Image (Pool.Physically_Deallocated)); 1785 1786 if Pool.Marked_Blocks_Deallocated then 1787 Put_Line ("Marked blocks were physically deallocated. This is"); 1788 Put_Line ("potentially dangerous, and you might want to run"); 1789 Put_Line ("again with a lower value of Minimum_To_Free"); 1790 end if; 1791 1792 Put_Line 1793 ("Current Water Mark: " & 1794 Byte_Count'Image (Pool.Current_Water_Mark)); 1795 1796 Put_Line 1797 ("High Water Mark: " & 1798 Byte_Count'Image (Pool.High_Water)); 1799 1800 Put_Line (""); 1801 1802 if Display_Slots then 1803 Data := Backtrace_Htable.Get_First; 1804 while Data /= null loop 1805 if Data.Kind in Alloc .. Dealloc then 1806 Elem := 1807 new Traceback_Htable_Elem' 1808 (Traceback => new Tracebacks_Array'(Data.Traceback.all), 1809 Count => Data.Count, 1810 Kind => Data.Kind, 1811 Total => Data.Total, 1812 Frees => Data.Frees, 1813 Total_Frees => Data.Total_Frees, 1814 Next => null); 1815 Backtrace_Htable_Cumulate.Set (Elem); 1816 1817 if Cumulate then 1818 K := (if Data.Kind = Alloc then Indirect_Alloc 1819 else Indirect_Dealloc); 1820 1821 -- Propagate the direct call to all its parents 1822 1823 for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop 1824 Elem := Backtrace_Htable_Cumulate.Get 1825 (Data.Traceback 1826 (T .. Data.Traceback'Last)'Unrestricted_Access); 1827 1828 -- If not, insert it 1829 1830 if Elem = null then 1831 Elem := 1832 new Traceback_Htable_Elem' 1833 (Traceback => 1834 new Tracebacks_Array' 1835 (Data.Traceback 1836 (T .. Data.Traceback'Last)), 1837 Count => Data.Count, 1838 Kind => K, 1839 Total => Data.Total, 1840 Frees => Data.Frees, 1841 Total_Frees => Data.Total_Frees, 1842 Next => null); 1843 Backtrace_Htable_Cumulate.Set (Elem); 1844 1845 -- Properly take into account that the subprograms 1846 -- indirectly called might be doing either allocations 1847 -- or deallocations. This needs to be reflected in the 1848 -- counts. 1849 1850 else 1851 Elem.Count := Elem.Count + Data.Count; 1852 1853 if K = Elem.Kind then 1854 Elem.Total := Elem.Total + Data.Total; 1855 1856 elsif Elem.Total > Data.Total then 1857 Elem.Total := Elem.Total - Data.Total; 1858 1859 else 1860 Elem.Kind := K; 1861 Elem.Total := Data.Total - Elem.Total; 1862 end if; 1863 end if; 1864 end loop; 1865 end if; 1866 1867 Data := Backtrace_Htable.Get_Next; 1868 end if; 1869 end loop; 1870 1871 Put_Line ("List of allocations/deallocations: "); 1872 1873 Data := Backtrace_Htable_Cumulate.Get_First; 1874 while Data /= null loop 1875 case Data.Kind is 1876 when Alloc => Put ("alloc (count:"); 1877 when Indirect_Alloc => Put ("indirect alloc (count:"); 1878 when Dealloc => Put ("free (count:"); 1879 when Indirect_Dealloc => Put ("indirect free (count:"); 1880 end case; 1881 1882 Put (Natural'Image (Data.Count) & ", total:" & 1883 Byte_Count'Image (Data.Total) & ") "); 1884 1885 for T in Data.Traceback'Range loop 1886 Put (Image_C (PC_For (Data.Traceback (T))) & ' '); 1887 end loop; 1888 1889 Put_Line (""); 1890 1891 Data := Backtrace_Htable_Cumulate.Get_Next; 1892 end loop; 1893 1894 Backtrace_Htable_Cumulate.Reset; 1895 end if; 1896 1897 if Display_Leaks then 1898 Put_Line (""); 1899 Put_Line ("List of not deallocated blocks:"); 1900 1901 -- Do not try to group the blocks with the same stack traces 1902 -- together. This is done by the gnatmem output. 1903 1904 Current := Pool.First_Used_Block; 1905 while Current /= System.Null_Address loop 1906 Header := Header_Of (Current); 1907 1908 Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: "); 1909 1910 if Header.Alloc_Traceback /= null then 1911 for T in Header.Alloc_Traceback.Traceback'Range loop 1912 Put (Image_C 1913 (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); 1914 end loop; 1915 end if; 1916 1917 Put_Line (""); 1918 Current := Header.Next; 1919 end loop; 1920 end if; 1921 end Print_Info; 1922 1923 ---------- 1924 -- Dump -- 1925 ---------- 1926 1927 procedure Dump 1928 (Pool : Debug_Pool; 1929 Size : Positive; 1930 Report : Report_Type := All_Reports) 1931 is 1932 procedure Do_Report (Sort : Report_Type); 1933 -- Do a specific type of report 1934 1935 --------------- 1936 -- Do_Report -- 1937 --------------- 1938 1939 procedure Do_Report (Sort : Report_Type) is 1940 Elem : Traceback_Htable_Elem_Ptr; 1941 Bigger : Boolean; 1942 Grand_Total : Float; 1943 1944 Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := 1945 (others => null); 1946 -- Sorted array for the biggest memory users 1947 1948 Allocated_In_Pool : Byte_Count; 1949 -- safe thread Pool.Allocated 1950 1951 Elem_Safe : Traceback_Htable_Elem; 1952 -- safe thread current elem.all; 1953 1954 Max_M_Safe : Traceback_Htable_Elem; 1955 -- safe thread Max(M).all 1956 1957 begin 1958 Put_Line (""); 1959 1960 case Sort is 1961 when All_Reports 1962 | Memory_Usage 1963 => 1964 Put_Line (Size'Img & " biggest memory users at this time:"); 1965 Put_Line ("Results include bytes and chunks still allocated"); 1966 Grand_Total := Float (Pool.Current_Water_Mark); 1967 1968 when Allocations_Count => 1969 Put_Line (Size'Img & " biggest number of live allocations:"); 1970 Put_Line ("Results include bytes and chunks still allocated"); 1971 Grand_Total := Float (Pool.Current_Water_Mark); 1972 1973 when Sort_Total_Allocs => 1974 Put_Line (Size'Img & " biggest number of allocations:"); 1975 Put_Line ("Results include total bytes and chunks allocated,"); 1976 Put_Line ("even if no longer allocated - Deallocations are" 1977 & " ignored"); 1978 1979 declare 1980 Lock : Scope_Lock; 1981 pragma Unreferenced (Lock); 1982 begin 1983 Allocated_In_Pool := Pool.Allocated; 1984 end; 1985 1986 Grand_Total := Float (Allocated_In_Pool); 1987 1988 when Marked_Blocks => 1989 Put_Line ("Special blocks marked by Mark_Traceback"); 1990 Grand_Total := 0.0; 1991 end case; 1992 1993 declare 1994 Lock : Scope_Lock; 1995 pragma Unreferenced (Lock); 1996 begin 1997 Elem := Backtrace_Htable.Get_First; 1998 end; 1999 2000 while Elem /= null loop 2001 declare 2002 Lock : Scope_Lock; 2003 pragma Unreferenced (Lock); 2004 begin 2005 Elem_Safe := Elem.all; 2006 end; 2007 2008 -- Handle only alloc elememts 2009 if Elem_Safe.Kind = Alloc then 2010 -- Ignore small blocks (depending on the sorting criteria) to 2011 -- gain speed. 2012 2013 if (Sort = Memory_Usage 2014 and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) 2015 or else (Sort = Allocations_Count 2016 and then Elem_Safe.Count - Elem_Safe.Frees >= 1) 2017 or else (Sort = Sort_Total_Allocs 2018 and then Elem_Safe.Count > 1) 2019 or else (Sort = Marked_Blocks 2020 and then Elem_Safe.Total = 0) 2021 then 2022 if Sort = Marked_Blocks then 2023 Grand_Total := Grand_Total + Float (Elem_Safe.Count); 2024 end if; 2025 2026 for M in Max'Range loop 2027 Bigger := Max (M) = null; 2028 if not Bigger then 2029 declare 2030 Lock : Scope_Lock; 2031 pragma Unreferenced (Lock); 2032 begin 2033 Max_M_Safe := Max (M).all; 2034 end; 2035 2036 case Sort is 2037 when All_Reports 2038 | Memory_Usage 2039 => 2040 Bigger := 2041 Max_M_Safe.Total - Max_M_Safe.Total_Frees 2042 < Elem_Safe.Total - Elem_Safe.Total_Frees; 2043 2044 when Allocations_Count => 2045 Bigger := 2046 Max_M_Safe.Count - Max_M_Safe.Frees 2047 < Elem_Safe.Count - Elem_Safe.Frees; 2048 2049 when Marked_Blocks 2050 | Sort_Total_Allocs 2051 => 2052 Bigger := Max_M_Safe.Count < Elem_Safe.Count; 2053 end case; 2054 end if; 2055 2056 if Bigger then 2057 Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); 2058 Max (M) := Elem; 2059 exit; 2060 end if; 2061 end loop; 2062 end if; 2063 end if; 2064 2065 declare 2066 Lock : Scope_Lock; 2067 pragma Unreferenced (Lock); 2068 begin 2069 Elem := Backtrace_Htable.Get_Next; 2070 end; 2071 end loop; 2072 2073 if Grand_Total = 0.0 then 2074 Grand_Total := 1.0; 2075 end if; 2076 2077 for M in Max'Range loop 2078 exit when Max (M) = null; 2079 declare 2080 type Percent is delta 0.1 range 0.0 .. 100.0; 2081 2082 P : Percent; 2083 Total : Byte_Count; 2084 2085 begin 2086 declare 2087 Lock : Scope_Lock; 2088 pragma Unreferenced (Lock); 2089 begin 2090 Max_M_Safe := Max (M).all; 2091 end; 2092 2093 case Sort is 2094 when All_Reports 2095 | Allocations_Count 2096 | Memory_Usage 2097 => 2098 Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; 2099 2100 when Sort_Total_Allocs => 2101 Total := Max_M_Safe.Total; 2102 2103 when Marked_Blocks => 2104 Total := Byte_Count (Max_M_Safe.Count); 2105 end case; 2106 2107 declare 2108 Normalized_Total : constant Float := Float (Total); 2109 -- In multi tasking configuration, memory deallocations 2110 -- during Do_Report processing can lead to Total > 2111 -- Grand_Total. As Percent requires Total <= Grand_Total 2112 2113 begin 2114 if Normalized_Total > Grand_Total then 2115 P := 100.0; 2116 else 2117 P := Percent (100.0 * Normalized_Total / Grand_Total); 2118 end if; 2119 end; 2120 2121 case Sort is 2122 when All_Reports 2123 | Allocations_Count 2124 | Memory_Usage 2125 => 2126 declare 2127 Count : constant Natural := 2128 Max_M_Safe.Count - Max_M_Safe.Frees; 2129 begin 2130 Put (P'Img & "%:" & Total'Img & " bytes in" 2131 & Count'Img & " chunks at"); 2132 end; 2133 2134 when Sort_Total_Allocs => 2135 Put (P'Img & "%:" & Total'Img & " bytes in" 2136 & Max_M_Safe.Count'Img & " chunks at"); 2137 2138 when Marked_Blocks => 2139 Put (P'Img & "%:" 2140 & Max_M_Safe.Count'Img & " chunks /" 2141 & Integer (Grand_Total)'Img & " at"); 2142 end case; 2143 end; 2144 2145 for J in Max (M).Traceback'Range loop 2146 Put (" " & Image_C (PC_For (Max (M).Traceback (J)))); 2147 end loop; 2148 2149 Put_Line (""); 2150 end loop; 2151 end Do_Report; 2152 2153 -- Local variables 2154 2155 Total_Freed : Byte_Count; 2156 -- safe thread pool logically & physically deallocated 2157 2158 Traceback_Elements_Allocated : Byte_Count; 2159 -- safe thread Traceback_Count 2160 2161 Validity_Elements_Allocated : Byte_Count; 2162 -- safe thread Validity_Count 2163 2164 Ada_Allocs_Bytes : Byte_Count; 2165 -- safe thread pool Allocated 2166 2167 Ada_Allocs_Chunks : Byte_Count; 2168 -- safe thread pool Alloc_Count 2169 2170 Ada_Free_Chunks : Byte_Count; 2171 -- safe thread pool Free_Count 2172 2173 -- Start of processing for Dump 2174 2175 begin 2176 declare 2177 Lock : Scope_Lock; 2178 pragma Unreferenced (Lock); 2179 begin 2180 Total_Freed := 2181 Pool.Logically_Deallocated + Pool.Physically_Deallocated; 2182 Traceback_Elements_Allocated := Traceback_Count; 2183 Validity_Elements_Allocated := Validity_Count; 2184 Ada_Allocs_Bytes := Pool.Allocated; 2185 Ada_Allocs_Chunks := Pool.Alloc_Count; 2186 Ada_Free_Chunks := Pool.Free_Count; 2187 end; 2188 2189 Put_Line 2190 ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); 2191 Put_Line 2192 ("Validity elements allocated: " & Validity_Elements_Allocated'Img); 2193 Put_Line (""); 2194 2195 Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img 2196 & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); 2197 Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & 2198 Ada_Free_Chunks'Img 2199 & " chunks"); 2200 Put_Line ("Ada Current watermark: " 2201 & Byte_Count'Image (Pool.Current_Water_Mark) 2202 & " in" & Byte_Count'Image (Ada_Allocs_Chunks - 2203 Ada_Free_Chunks) & " chunks"); 2204 Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); 2205 2206 case Report is 2207 when All_Reports => 2208 for Sort in Report_Type loop 2209 if Sort /= All_Reports then 2210 Do_Report (Sort); 2211 end if; 2212 end loop; 2213 2214 when others => 2215 Do_Report (Report); 2216 end case; 2217 end Dump; 2218 2219 ----------------- 2220 -- Dump_Stdout -- 2221 ----------------- 2222 2223 procedure Dump_Stdout 2224 (Pool : Debug_Pool; 2225 Size : Positive; 2226 Report : Report_Type := All_Reports) 2227 is 2228 procedure Internal is new Dump 2229 (Put_Line => Stdout_Put_Line, 2230 Put => Stdout_Put); 2231 2232 -- Start of processing for Dump_Stdout 2233 2234 begin 2235 Internal (Pool, Size, Report); 2236 end Dump_Stdout; 2237 2238 ----------- 2239 -- Reset -- 2240 ----------- 2241 2242 procedure Reset is 2243 Elem : Traceback_Htable_Elem_Ptr; 2244 Lock : Scope_Lock; 2245 pragma Unreferenced (Lock); 2246 begin 2247 Elem := Backtrace_Htable.Get_First; 2248 while Elem /= null loop 2249 Elem.Count := 0; 2250 Elem.Frees := 0; 2251 Elem.Total := 0; 2252 Elem.Total_Frees := 0; 2253 Elem := Backtrace_Htable.Get_Next; 2254 end loop; 2255 end Reset; 2256 2257 ------------------ 2258 -- Storage_Size -- 2259 ------------------ 2260 2261 function Storage_Size (Pool : Debug_Pool) return Storage_Count is 2262 pragma Unreferenced (Pool); 2263 begin 2264 return Storage_Count'Last; 2265 end Storage_Size; 2266 2267 --------------------- 2268 -- High_Water_Mark -- 2269 --------------------- 2270 2271 function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is 2272 Lock : Scope_Lock; 2273 pragma Unreferenced (Lock); 2274 begin 2275 return Pool.High_Water; 2276 end High_Water_Mark; 2277 2278 ------------------------ 2279 -- Current_Water_Mark -- 2280 ------------------------ 2281 2282 function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is 2283 Lock : Scope_Lock; 2284 pragma Unreferenced (Lock); 2285 begin 2286 return Pool.Allocated - Pool.Logically_Deallocated - 2287 Pool.Physically_Deallocated; 2288 end Current_Water_Mark; 2289 2290 ------------------------------ 2291 -- System_Memory_Debug_Pool -- 2292 ------------------------------ 2293 2294 procedure System_Memory_Debug_Pool 2295 (Has_Unhandled_Memory : Boolean := True) 2296 is 2297 Lock : Scope_Lock; 2298 pragma Unreferenced (Lock); 2299 begin 2300 System_Memory_Debug_Pool_Enabled := True; 2301 Allow_Unhandled_Memory := Has_Unhandled_Memory; 2302 end System_Memory_Debug_Pool; 2303 2304 --------------- 2305 -- Configure -- 2306 --------------- 2307 2308 procedure Configure 2309 (Pool : in out Debug_Pool; 2310 Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; 2311 Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; 2312 Minimum_To_Free : SSC := Default_Min_Freed; 2313 Reset_Content_On_Free : Boolean := Default_Reset_Content; 2314 Raise_Exceptions : Boolean := Default_Raise_Exceptions; 2315 Advanced_Scanning : Boolean := Default_Advanced_Scanning; 2316 Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; 2317 Low_Level_Traces : Boolean := Default_Low_Level_Traces) 2318 is 2319 Lock : Scope_Lock; 2320 pragma Unreferenced (Lock); 2321 begin 2322 Pool.Stack_Trace_Depth := Stack_Trace_Depth; 2323 Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory; 2324 Pool.Reset_Content_On_Free := Reset_Content_On_Free; 2325 Pool.Raise_Exceptions := Raise_Exceptions; 2326 Pool.Minimum_To_Free := Minimum_To_Free; 2327 Pool.Advanced_Scanning := Advanced_Scanning; 2328 Pool.Errors_To_Stdout := Errors_To_Stdout; 2329 Pool.Low_Level_Traces := Low_Level_Traces; 2330 end Configure; 2331 2332 ---------------- 2333 -- Print_Pool -- 2334 ---------------- 2335 2336 procedure Print_Pool (A : System.Address) is 2337 Storage : constant Address := A; 2338 Valid : constant Boolean := Is_Valid (Storage); 2339 Header : Allocation_Header_Access; 2340 2341 begin 2342 -- We might get Null_Address if the call from gdb was done incorrectly. 2343 -- For instance, doing a "print_pool(my_var)" passes 0x0, instead of 2344 -- passing the value of my_var. 2345 2346 if A = System.Null_Address then 2347 Put_Line 2348 (Standard_Output, "Memory not under control of the storage pool"); 2349 return; 2350 end if; 2351 2352 if not Valid then 2353 Put_Line 2354 (Standard_Output, "Memory not under control of the storage pool"); 2355 2356 else 2357 Header := Header_Of (Storage); 2358 Print_Address (Standard_Output, A); 2359 Put_Line (Standard_Output, " allocated at:"); 2360 Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); 2361 2362 if To_Traceback (Header.Dealloc_Traceback) /= null then 2363 Print_Address (Standard_Output, A); 2364 Put_Line (Standard_Output, 2365 " logically freed memory, deallocated at:"); 2366 Print_Traceback (Standard_Output, "", 2367 To_Traceback (Header.Dealloc_Traceback)); 2368 end if; 2369 end if; 2370 end Print_Pool; 2371 2372 ----------------------- 2373 -- Print_Info_Stdout -- 2374 ----------------------- 2375 2376 procedure Print_Info_Stdout 2377 (Pool : Debug_Pool; 2378 Cumulate : Boolean := False; 2379 Display_Slots : Boolean := False; 2380 Display_Leaks : Boolean := False) 2381 is 2382 procedure Internal is new Print_Info 2383 (Put_Line => Stdout_Put_Line, 2384 Put => Stdout_Put); 2385 2386 -- Start of processing for Print_Info_Stdout 2387 2388 begin 2389 Internal (Pool, Cumulate, Display_Slots, Display_Leaks); 2390 end Print_Info_Stdout; 2391 2392 ------------------ 2393 -- Dump_Gnatmem -- 2394 ------------------ 2395 2396 procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is 2397 type File_Ptr is new System.Address; 2398 2399 function fopen (Path : String; Mode : String) return File_Ptr; 2400 pragma Import (C, fopen); 2401 2402 procedure fwrite 2403 (Ptr : System.Address; 2404 Size : size_t; 2405 Nmemb : size_t; 2406 Stream : File_Ptr); 2407 2408 procedure fwrite 2409 (Str : String; 2410 Size : size_t; 2411 Nmemb : size_t; 2412 Stream : File_Ptr); 2413 pragma Import (C, fwrite); 2414 2415 procedure fputc (C : Integer; Stream : File_Ptr); 2416 pragma Import (C, fputc); 2417 2418 procedure fclose (Stream : File_Ptr); 2419 pragma Import (C, fclose); 2420 2421 Address_Size : constant size_t := 2422 System.Address'Max_Size_In_Storage_Elements; 2423 -- Size in bytes of a pointer 2424 2425 File : File_Ptr; 2426 Current : System.Address; 2427 Header : Allocation_Header_Access; 2428 Actual_Size : size_t; 2429 Num_Calls : Integer; 2430 Tracebk : Tracebacks_Array_Access; 2431 Dummy_Time : Duration := 1.0; 2432 2433 begin 2434 File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); 2435 fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); 2436 2437 fwrite 2438 (Ptr => Dummy_Time'Address, 2439 Size => Duration'Max_Size_In_Storage_Elements, 2440 Nmemb => 1, 2441 Stream => File); 2442 2443 -- List of not deallocated blocks (see Print_Info) 2444 2445 Current := Pool.First_Used_Block; 2446 while Current /= System.Null_Address loop 2447 Header := Header_Of (Current); 2448 2449 Actual_Size := size_t (Header.Block_Size); 2450 2451 if Header.Alloc_Traceback /= null then 2452 Tracebk := Header.Alloc_Traceback.Traceback; 2453 Num_Calls := Tracebk'Length; 2454 2455 -- (Code taken from memtrack.adb in GNAT's sources) 2456 2457 -- Logs allocation call using the format: 2458 2459 -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> 2460 2461 fputc (Character'Pos ('A'), File); 2462 fwrite (Current'Address, Address_Size, 1, File); 2463 2464 fwrite 2465 (Ptr => Actual_Size'Address, 2466 Size => size_t'Max_Size_In_Storage_Elements, 2467 Nmemb => 1, 2468 Stream => File); 2469 2470 fwrite 2471 (Ptr => Dummy_Time'Address, 2472 Size => Duration'Max_Size_In_Storage_Elements, 2473 Nmemb => 1, 2474 Stream => File); 2475 2476 fwrite 2477 (Ptr => Num_Calls'Address, 2478 Size => Integer'Max_Size_In_Storage_Elements, 2479 Nmemb => 1, 2480 Stream => File); 2481 2482 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop 2483 declare 2484 Ptr : System.Address := PC_For (Tracebk (J)); 2485 begin 2486 fwrite (Ptr'Address, Address_Size, 1, File); 2487 end; 2488 end loop; 2489 end if; 2490 2491 Current := Header.Next; 2492 end loop; 2493 2494 fclose (File); 2495 end Dump_Gnatmem; 2496 2497 ---------------- 2498 -- Stdout_Put -- 2499 ---------------- 2500 2501 procedure Stdout_Put (S : String) is 2502 begin 2503 Put (Standard_Output, S); 2504 end Stdout_Put; 2505 2506 --------------------- 2507 -- Stdout_Put_Line -- 2508 --------------------- 2509 2510 procedure Stdout_Put_Line (S : String) is 2511 begin 2512 Put_Line (Standard_Output, S); 2513 end Stdout_Put_Line; 2514 2515-- Package initialization 2516 2517begin 2518 Allocate_End; 2519 Deallocate_End; 2520 Dereference_End; 2521end GNAT.Debug_Pools; 2522