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-2018, 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 1424 if Is_Valid (Storage_Address) then 1425 declare 1426 Header : constant Allocation_Header_Access := 1427 Header_Of (Storage_Address); 1428 1429 begin 1430 if Header.Block_Size >= 0 then 1431 Valid := True; 1432 Size_In_Storage_Elements := Header.Block_Size; 1433 else 1434 Valid := False; 1435 end if; 1436 end; 1437 else 1438 Valid := False; 1439 end if; 1440 end Get_Size; 1441 1442 --------------------- 1443 -- Print_Traceback -- 1444 --------------------- 1445 1446 procedure Print_Traceback 1447 (Output_File : File_Type; 1448 Prefix : String; 1449 Traceback : Traceback_Htable_Elem_Ptr) 1450 is 1451 begin 1452 if Traceback /= null then 1453 Put (Output_File, Prefix); 1454 Put_Line (Output_File, 0, Traceback.Traceback); 1455 end if; 1456 end Print_Traceback; 1457 1458 ---------------- 1459 -- Deallocate -- 1460 ---------------- 1461 1462 procedure Deallocate 1463 (Pool : in out Debug_Pool; 1464 Storage_Address : Address; 1465 Size_In_Storage_Elements : Storage_Count; 1466 Alignment : Storage_Count) 1467 is 1468 pragma Unreferenced (Alignment); 1469 1470 Header : constant Allocation_Header_Access := 1471 Header_Of (Storage_Address); 1472 Previous : System.Address; 1473 Valid : Boolean; 1474 1475 Header_Block_Size_Was_Less_Than_0 : Boolean := True; 1476 1477 begin 1478 <<Deallocate_Label>> 1479 1480 declare 1481 Lock : Scope_Lock; 1482 pragma Unreferenced (Lock); 1483 1484 begin 1485 Valid := Is_Valid (Storage_Address); 1486 1487 if Valid and then not (Header.Block_Size < 0) then 1488 Header_Block_Size_Was_Less_Than_0 := False; 1489 1490 -- Some sort of codegen problem or heap corruption caused the 1491 -- Size_In_Storage_Elements to be wrongly computed. The code 1492 -- below is all based on the assumption that Header.all is not 1493 -- corrupted, such that the error is non-fatal. 1494 1495 if Header.Block_Size /= Size_In_Storage_Elements and then 1496 Size_In_Storage_Elements /= Storage_Count'Last 1497 then 1498 Put_Line (Output_File (Pool), 1499 "error: Deallocate size " 1500 & Storage_Count'Image (Size_In_Storage_Elements) 1501 & " does not match allocate size " 1502 & Storage_Count'Image (Header.Block_Size)); 1503 end if; 1504 1505 if Pool.Low_Level_Traces then 1506 Put (Output_File (Pool), 1507 "info: Deallocated" 1508 & Storage_Count'Image (Header.Block_Size) 1509 & " bytes at "); 1510 Print_Address (Output_File (Pool), Storage_Address); 1511 Put (Output_File (Pool), 1512 " (physically" 1513 & Storage_Count'Image 1514 (Header.Block_Size + Extra_Allocation) 1515 & " bytes at "); 1516 Print_Address (Output_File (Pool), Header.Allocation_Address); 1517 Put (Output_File (Pool), "), at "); 1518 1519 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1520 Deallocate_Label'Address, 1521 Code_Address_For_Deallocate_End); 1522 Print_Traceback (Output_File (Pool), 1523 " Memory was allocated at ", 1524 Header.Alloc_Traceback); 1525 end if; 1526 1527 -- Remove this block from the list of used blocks 1528 1529 Previous := 1530 To_Address (Header.Dealloc_Traceback); 1531 1532 if Previous = System.Null_Address then 1533 Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; 1534 1535 if Pool.First_Used_Block /= System.Null_Address then 1536 Header_Of (Pool.First_Used_Block).Dealloc_Traceback := 1537 To_Traceback (null); 1538 end if; 1539 1540 else 1541 Header_Of (Previous).Next := Header.Next; 1542 1543 if Header.Next /= System.Null_Address then 1544 Header_Of 1545 (Header.Next).Dealloc_Traceback := To_Address (Previous); 1546 end if; 1547 end if; 1548 1549 -- Update the Alloc_Traceback Frees/Total_Frees members 1550 -- (if present) 1551 1552 if Header.Alloc_Traceback /= null then 1553 Header.Alloc_Traceback.Frees := 1554 Header.Alloc_Traceback.Frees + 1; 1555 Header.Alloc_Traceback.Total_Frees := 1556 Header.Alloc_Traceback.Total_Frees + 1557 Byte_Count (Header.Block_Size); 1558 end if; 1559 1560 Pool.Free_Count := Pool.Free_Count + 1; 1561 1562 -- Update the header 1563 1564 Header.all := 1565 (Allocation_Address => Header.Allocation_Address, 1566 Alloc_Traceback => Header.Alloc_Traceback, 1567 Dealloc_Traceback => To_Traceback 1568 (Find_Or_Create_Traceback 1569 (Pool, Dealloc, 1570 Header.Block_Size, 1571 Deallocate_Label'Address, 1572 Code_Address_For_Deallocate_End)), 1573 Next => System.Null_Address, 1574 Block_Size => -Header.Block_Size); 1575 1576 if Pool.Reset_Content_On_Free then 1577 Set_Dead_Beef (Storage_Address, -Header.Block_Size); 1578 end if; 1579 1580 Pool.Logically_Deallocated := 1581 Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); 1582 1583 -- Link this free block with the others (at the end of the list, 1584 -- so that we can start releasing the older blocks first later on) 1585 1586 if Pool.First_Free_Block = System.Null_Address then 1587 Pool.First_Free_Block := Storage_Address; 1588 Pool.Last_Free_Block := Storage_Address; 1589 1590 else 1591 Header_Of (Pool.Last_Free_Block).Next := Storage_Address; 1592 Pool.Last_Free_Block := Storage_Address; 1593 end if; 1594 1595 -- Do not physically release the memory here, but in Alloc. 1596 -- See comment there for details. 1597 end if; 1598 end; 1599 1600 if not Valid then 1601 if Storage_Address = System.Null_Address then 1602 if Pool.Raise_Exceptions and then 1603 Size_In_Storage_Elements /= Storage_Count'Last 1604 then 1605 raise Freeing_Not_Allocated_Storage; 1606 else 1607 Put (Output_File (Pool), 1608 "error: Freeing Null_Address, at "); 1609 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1610 Deallocate_Label'Address, 1611 Code_Address_For_Deallocate_End); 1612 return; 1613 end if; 1614 end if; 1615 1616 if Allow_Unhandled_Memory 1617 and then not Is_Handled (Storage_Address) 1618 then 1619 System.CRTL.free (Storage_Address); 1620 return; 1621 end if; 1622 1623 if Pool.Raise_Exceptions 1624 and then Size_In_Storage_Elements /= Storage_Count'Last 1625 then 1626 raise Freeing_Not_Allocated_Storage; 1627 else 1628 Put (Output_File (Pool), 1629 "error: Freeing not allocated storage, at "); 1630 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1631 Deallocate_Label'Address, 1632 Code_Address_For_Deallocate_End); 1633 end if; 1634 1635 elsif Header_Block_Size_Was_Less_Than_0 then 1636 if Pool.Raise_Exceptions then 1637 raise Freeing_Deallocated_Storage; 1638 else 1639 Put (Output_File (Pool), 1640 "error: Freeing already deallocated storage, at "); 1641 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1642 Deallocate_Label'Address, 1643 Code_Address_For_Deallocate_End); 1644 Print_Traceback (Output_File (Pool), 1645 " Memory already deallocated at ", 1646 To_Traceback (Header.Dealloc_Traceback)); 1647 Print_Traceback (Output_File (Pool), " Memory was allocated at ", 1648 Header.Alloc_Traceback); 1649 end if; 1650 end if; 1651 end Deallocate; 1652 1653 -------------------- 1654 -- Deallocate_End -- 1655 -------------------- 1656 1657 -- DO NOT MOVE, this must be right after Deallocate 1658 1659 -- See Allocate_End 1660 1661 -- This is making assumptions about code order that may be invalid ??? 1662 1663 procedure Deallocate_End is 1664 begin 1665 <<Deallocate_End_Label>> 1666 Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; 1667 end Deallocate_End; 1668 1669 ----------------- 1670 -- Dereference -- 1671 ----------------- 1672 1673 procedure Dereference 1674 (Pool : in out Debug_Pool; 1675 Storage_Address : Address; 1676 Size_In_Storage_Elements : Storage_Count; 1677 Alignment : Storage_Count) 1678 is 1679 pragma Unreferenced (Alignment, Size_In_Storage_Elements); 1680 1681 Valid : constant Boolean := Is_Valid (Storage_Address); 1682 Header : Allocation_Header_Access; 1683 1684 begin 1685 -- Locking policy: we do not do any locking in this procedure. The 1686 -- tables are only read, not written to, and although a problem might 1687 -- appear if someone else is modifying the tables at the same time, this 1688 -- race condition is not intended to be detected by this storage_pool (a 1689 -- now invalid pointer would appear as valid). Instead, we prefer 1690 -- optimum performance for dereferences. 1691 1692 <<Dereference_Label>> 1693 1694 if not Valid then 1695 if Pool.Raise_Exceptions then 1696 raise Accessing_Not_Allocated_Storage; 1697 else 1698 Put (Output_File (Pool), 1699 "error: Accessing not allocated storage, at "); 1700 Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1701 Dereference_Label'Address, 1702 Code_Address_For_Dereference_End); 1703 end if; 1704 1705 else 1706 Header := Header_Of (Storage_Address); 1707 1708 if Header.Block_Size < 0 then 1709 if Pool.Raise_Exceptions then 1710 raise Accessing_Deallocated_Storage; 1711 else 1712 Put (Output_File (Pool), 1713 "error: Accessing deallocated storage, at "); 1714 Put_Line 1715 (Output_File (Pool), Pool.Stack_Trace_Depth, null, 1716 Dereference_Label'Address, 1717 Code_Address_For_Dereference_End); 1718 Print_Traceback (Output_File (Pool), " First deallocation at ", 1719 To_Traceback (Header.Dealloc_Traceback)); 1720 Print_Traceback (Output_File (Pool), " Initial allocation at ", 1721 Header.Alloc_Traceback); 1722 end if; 1723 end if; 1724 end if; 1725 end Dereference; 1726 1727 --------------------- 1728 -- Dereference_End -- 1729 --------------------- 1730 1731 -- DO NOT MOVE: this must be right after Dereference 1732 1733 -- See Allocate_End 1734 1735 -- This is making assumptions about code order that may be invalid ??? 1736 1737 procedure Dereference_End is 1738 begin 1739 <<Dereference_End_Label>> 1740 Code_Address_For_Dereference_End := Dereference_End_Label'Address; 1741 end Dereference_End; 1742 1743 ---------------- 1744 -- Print_Info -- 1745 ---------------- 1746 1747 procedure Print_Info 1748 (Pool : Debug_Pool; 1749 Cumulate : Boolean := False; 1750 Display_Slots : Boolean := False; 1751 Display_Leaks : Boolean := False) 1752 is 1753 package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable 1754 (Header_Num => Header, 1755 Element => Traceback_Htable_Elem, 1756 Elmt_Ptr => Traceback_Htable_Elem_Ptr, 1757 Null_Ptr => null, 1758 Set_Next => Set_Next, 1759 Next => Next, 1760 Key => Tracebacks_Array_Access, 1761 Get_Key => Get_Key, 1762 Hash => Hash, 1763 Equal => Equal); 1764 -- This needs a comment ??? probably some of the ones below do too??? 1765 1766 Current : System.Address; 1767 Data : Traceback_Htable_Elem_Ptr; 1768 Elem : Traceback_Htable_Elem_Ptr; 1769 Header : Allocation_Header_Access; 1770 K : Traceback_Kind; 1771 1772 begin 1773 Put_Line 1774 ("Total allocated bytes : " & 1775 Byte_Count'Image (Pool.Allocated)); 1776 1777 Put_Line 1778 ("Total logically deallocated bytes : " & 1779 Byte_Count'Image (Pool.Logically_Deallocated)); 1780 1781 Put_Line 1782 ("Total physically deallocated bytes : " & 1783 Byte_Count'Image (Pool.Physically_Deallocated)); 1784 1785 if Pool.Marked_Blocks_Deallocated then 1786 Put_Line ("Marked blocks were physically deallocated. This is"); 1787 Put_Line ("potentially dangerous, and you might want to run"); 1788 Put_Line ("again with a lower value of Minimum_To_Free"); 1789 end if; 1790 1791 Put_Line 1792 ("Current Water Mark: " & 1793 Byte_Count'Image (Pool.Current_Water_Mark)); 1794 1795 Put_Line 1796 ("High Water Mark: " & 1797 Byte_Count'Image (Pool.High_Water)); 1798 1799 Put_Line (""); 1800 1801 if Display_Slots then 1802 Data := Backtrace_Htable.Get_First; 1803 while Data /= null loop 1804 if Data.Kind in Alloc .. Dealloc then 1805 Elem := 1806 new Traceback_Htable_Elem' 1807 (Traceback => new Tracebacks_Array'(Data.Traceback.all), 1808 Count => Data.Count, 1809 Kind => Data.Kind, 1810 Total => Data.Total, 1811 Frees => Data.Frees, 1812 Total_Frees => Data.Total_Frees, 1813 Next => null); 1814 Backtrace_Htable_Cumulate.Set (Elem); 1815 1816 if Cumulate then 1817 K := (if Data.Kind = Alloc then Indirect_Alloc 1818 else Indirect_Dealloc); 1819 1820 -- Propagate the direct call to all its parents 1821 1822 for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop 1823 Elem := Backtrace_Htable_Cumulate.Get 1824 (Data.Traceback 1825 (T .. Data.Traceback'Last)'Unrestricted_Access); 1826 1827 -- If not, insert it 1828 1829 if Elem = null then 1830 Elem := 1831 new Traceback_Htable_Elem' 1832 (Traceback => 1833 new Tracebacks_Array' 1834 (Data.Traceback 1835 (T .. Data.Traceback'Last)), 1836 Count => Data.Count, 1837 Kind => K, 1838 Total => Data.Total, 1839 Frees => Data.Frees, 1840 Total_Frees => Data.Total_Frees, 1841 Next => null); 1842 Backtrace_Htable_Cumulate.Set (Elem); 1843 1844 -- Properly take into account that the subprograms 1845 -- indirectly called might be doing either allocations 1846 -- or deallocations. This needs to be reflected in the 1847 -- counts. 1848 1849 else 1850 Elem.Count := Elem.Count + Data.Count; 1851 1852 if K = Elem.Kind then 1853 Elem.Total := Elem.Total + Data.Total; 1854 1855 elsif Elem.Total > Data.Total then 1856 Elem.Total := Elem.Total - Data.Total; 1857 1858 else 1859 Elem.Kind := K; 1860 Elem.Total := Data.Total - Elem.Total; 1861 end if; 1862 end if; 1863 end loop; 1864 end if; 1865 1866 Data := Backtrace_Htable.Get_Next; 1867 end if; 1868 end loop; 1869 1870 Put_Line ("List of allocations/deallocations: "); 1871 1872 Data := Backtrace_Htable_Cumulate.Get_First; 1873 while Data /= null loop 1874 case Data.Kind is 1875 when Alloc => Put ("alloc (count:"); 1876 when Indirect_Alloc => Put ("indirect alloc (count:"); 1877 when Dealloc => Put ("free (count:"); 1878 when Indirect_Dealloc => Put ("indirect free (count:"); 1879 end case; 1880 1881 Put (Natural'Image (Data.Count) & ", total:" & 1882 Byte_Count'Image (Data.Total) & ") "); 1883 1884 for T in Data.Traceback'Range loop 1885 Put (Image_C (PC_For (Data.Traceback (T))) & ' '); 1886 end loop; 1887 1888 Put_Line (""); 1889 1890 Data := Backtrace_Htable_Cumulate.Get_Next; 1891 end loop; 1892 1893 Backtrace_Htable_Cumulate.Reset; 1894 end if; 1895 1896 if Display_Leaks then 1897 Put_Line (""); 1898 Put_Line ("List of not deallocated blocks:"); 1899 1900 -- Do not try to group the blocks with the same stack traces 1901 -- together. This is done by the gnatmem output. 1902 1903 Current := Pool.First_Used_Block; 1904 while Current /= System.Null_Address loop 1905 Header := Header_Of (Current); 1906 1907 Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: "); 1908 1909 if Header.Alloc_Traceback /= null then 1910 for T in Header.Alloc_Traceback.Traceback'Range loop 1911 Put (Image_C 1912 (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); 1913 end loop; 1914 end if; 1915 1916 Put_Line (""); 1917 Current := Header.Next; 1918 end loop; 1919 end if; 1920 end Print_Info; 1921 1922 ---------- 1923 -- Dump -- 1924 ---------- 1925 1926 procedure Dump 1927 (Pool : Debug_Pool; 1928 Size : Positive; 1929 Report : Report_Type := All_Reports) 1930 is 1931 procedure Do_Report (Sort : Report_Type); 1932 -- Do a specific type of report 1933 1934 --------------- 1935 -- Do_Report -- 1936 --------------- 1937 1938 procedure Do_Report (Sort : Report_Type) is 1939 Elem : Traceback_Htable_Elem_Ptr; 1940 Bigger : Boolean; 1941 Grand_Total : Float; 1942 1943 Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := 1944 (others => null); 1945 -- Sorted array for the biggest memory users 1946 1947 Allocated_In_Pool : Byte_Count; 1948 -- safe thread Pool.Allocated 1949 1950 Elem_Safe : Traceback_Htable_Elem; 1951 -- safe thread current elem.all; 1952 1953 Max_M_Safe : Traceback_Htable_Elem; 1954 -- safe thread Max(M).all 1955 1956 begin 1957 Put_Line (""); 1958 1959 case Sort is 1960 when All_Reports 1961 | Memory_Usage 1962 => 1963 Put_Line (Size'Img & " biggest memory users at this time:"); 1964 Put_Line ("Results include bytes and chunks still allocated"); 1965 Grand_Total := Float (Pool.Current_Water_Mark); 1966 1967 when Allocations_Count => 1968 Put_Line (Size'Img & " biggest number of live allocations:"); 1969 Put_Line ("Results include bytes and chunks still allocated"); 1970 Grand_Total := Float (Pool.Current_Water_Mark); 1971 1972 when Sort_Total_Allocs => 1973 Put_Line (Size'Img & " biggest number of allocations:"); 1974 Put_Line ("Results include total bytes and chunks allocated,"); 1975 Put_Line ("even if no longer allocated - Deallocations are" 1976 & " ignored"); 1977 1978 declare 1979 Lock : Scope_Lock; 1980 pragma Unreferenced (Lock); 1981 begin 1982 Allocated_In_Pool := Pool.Allocated; 1983 end; 1984 1985 Grand_Total := Float (Allocated_In_Pool); 1986 1987 when Marked_Blocks => 1988 Put_Line ("Special blocks marked by Mark_Traceback"); 1989 Grand_Total := 0.0; 1990 end case; 1991 1992 declare 1993 Lock : Scope_Lock; 1994 pragma Unreferenced (Lock); 1995 begin 1996 Elem := Backtrace_Htable.Get_First; 1997 end; 1998 1999 while Elem /= null loop 2000 declare 2001 Lock : Scope_Lock; 2002 pragma Unreferenced (Lock); 2003 begin 2004 Elem_Safe := Elem.all; 2005 end; 2006 2007 -- Handle only alloc elememts 2008 if Elem_Safe.Kind = Alloc then 2009 -- Ignore small blocks (depending on the sorting criteria) to 2010 -- gain speed. 2011 2012 if (Sort = Memory_Usage 2013 and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) 2014 or else (Sort = Allocations_Count 2015 and then Elem_Safe.Count - Elem_Safe.Frees >= 1) 2016 or else (Sort = Sort_Total_Allocs 2017 and then Elem_Safe.Count > 1) 2018 or else (Sort = Marked_Blocks 2019 and then Elem_Safe.Total = 0) 2020 then 2021 if Sort = Marked_Blocks then 2022 Grand_Total := Grand_Total + Float (Elem_Safe.Count); 2023 end if; 2024 2025 for M in Max'Range loop 2026 Bigger := Max (M) = null; 2027 if not Bigger then 2028 declare 2029 Lock : Scope_Lock; 2030 pragma Unreferenced (Lock); 2031 begin 2032 Max_M_Safe := Max (M).all; 2033 end; 2034 2035 case Sort is 2036 when All_Reports 2037 | Memory_Usage 2038 => 2039 Bigger := 2040 Max_M_Safe.Total - Max_M_Safe.Total_Frees 2041 < Elem_Safe.Total - Elem_Safe.Total_Frees; 2042 2043 when Allocations_Count => 2044 Bigger := 2045 Max_M_Safe.Count - Max_M_Safe.Frees 2046 < Elem_Safe.Count - Elem_Safe.Frees; 2047 2048 when Marked_Blocks 2049 | Sort_Total_Allocs 2050 => 2051 Bigger := Max_M_Safe.Count < Elem_Safe.Count; 2052 end case; 2053 end if; 2054 2055 if Bigger then 2056 Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); 2057 Max (M) := Elem; 2058 exit; 2059 end if; 2060 end loop; 2061 end if; 2062 end if; 2063 2064 declare 2065 Lock : Scope_Lock; 2066 pragma Unreferenced (Lock); 2067 begin 2068 Elem := Backtrace_Htable.Get_Next; 2069 end; 2070 end loop; 2071 2072 if Grand_Total = 0.0 then 2073 Grand_Total := 1.0; 2074 end if; 2075 2076 for M in Max'Range loop 2077 exit when Max (M) = null; 2078 declare 2079 type Percent is delta 0.1 range 0.0 .. 100.0; 2080 2081 P : Percent; 2082 Total : Byte_Count; 2083 2084 begin 2085 declare 2086 Lock : Scope_Lock; 2087 pragma Unreferenced (Lock); 2088 begin 2089 Max_M_Safe := Max (M).all; 2090 end; 2091 2092 case Sort is 2093 when All_Reports 2094 | Allocations_Count 2095 | Memory_Usage 2096 => 2097 Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; 2098 2099 when Sort_Total_Allocs => 2100 Total := Max_M_Safe.Total; 2101 2102 when Marked_Blocks => 2103 Total := Byte_Count (Max_M_Safe.Count); 2104 end case; 2105 2106 declare 2107 Normalized_Total : constant Float := Float (Total); 2108 -- In multi tasking configuration, memory deallocations 2109 -- during Do_Report processing can lead to Total > 2110 -- Grand_Total. As Percent requires Total <= Grand_Total 2111 2112 begin 2113 if Normalized_Total > Grand_Total then 2114 P := 100.0; 2115 else 2116 P := Percent (100.0 * Normalized_Total / Grand_Total); 2117 end if; 2118 end; 2119 2120 case Sort is 2121 when All_Reports 2122 | Allocations_Count 2123 | Memory_Usage 2124 => 2125 declare 2126 Count : constant Natural := 2127 Max_M_Safe.Count - Max_M_Safe.Frees; 2128 begin 2129 Put (P'Img & "%:" & Total'Img & " bytes in" 2130 & Count'Img & " chunks at"); 2131 end; 2132 2133 when Sort_Total_Allocs => 2134 Put (P'Img & "%:" & Total'Img & " bytes in" 2135 & Max_M_Safe.Count'Img & " chunks at"); 2136 2137 when Marked_Blocks => 2138 Put (P'Img & "%:" 2139 & Max_M_Safe.Count'Img & " chunks /" 2140 & Integer (Grand_Total)'Img & " at"); 2141 end case; 2142 end; 2143 2144 for J in Max (M).Traceback'Range loop 2145 Put (" " & Image_C (PC_For (Max (M).Traceback (J)))); 2146 end loop; 2147 2148 Put_Line (""); 2149 end loop; 2150 end Do_Report; 2151 2152 -- Local variables 2153 2154 Total_Freed : Byte_Count; 2155 -- safe thread pool logically & physically deallocated 2156 2157 Traceback_Elements_Allocated : Byte_Count; 2158 -- safe thread Traceback_Count 2159 2160 Validity_Elements_Allocated : Byte_Count; 2161 -- safe thread Validity_Count 2162 2163 Ada_Allocs_Bytes : Byte_Count; 2164 -- safe thread pool Allocated 2165 2166 Ada_Allocs_Chunks : Byte_Count; 2167 -- safe thread pool Alloc_Count 2168 2169 Ada_Free_Chunks : Byte_Count; 2170 -- safe thread pool Free_Count 2171 2172 -- Start of processing for Dump 2173 2174 begin 2175 declare 2176 Lock : Scope_Lock; 2177 pragma Unreferenced (Lock); 2178 begin 2179 Total_Freed := 2180 Pool.Logically_Deallocated + Pool.Physically_Deallocated; 2181 Traceback_Elements_Allocated := Traceback_Count; 2182 Validity_Elements_Allocated := Validity_Count; 2183 Ada_Allocs_Bytes := Pool.Allocated; 2184 Ada_Allocs_Chunks := Pool.Alloc_Count; 2185 Ada_Free_Chunks := Pool.Free_Count; 2186 end; 2187 2188 Put_Line 2189 ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); 2190 Put_Line 2191 ("Validity elements allocated: " & Validity_Elements_Allocated'Img); 2192 Put_Line (""); 2193 2194 Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img 2195 & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); 2196 Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & 2197 Ada_Free_Chunks'Img 2198 & " chunks"); 2199 Put_Line ("Ada Current watermark: " 2200 & Byte_Count'Image (Pool.Current_Water_Mark) 2201 & " in" & Byte_Count'Image (Ada_Allocs_Chunks - 2202 Ada_Free_Chunks) & " chunks"); 2203 Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); 2204 2205 case Report is 2206 when All_Reports => 2207 for Sort in Report_Type loop 2208 if Sort /= All_Reports then 2209 Do_Report (Sort); 2210 end if; 2211 end loop; 2212 2213 when others => 2214 Do_Report (Report); 2215 end case; 2216 end Dump; 2217 2218 ----------------- 2219 -- Dump_Stdout -- 2220 ----------------- 2221 2222 procedure Dump_Stdout 2223 (Pool : Debug_Pool; 2224 Size : Positive; 2225 Report : Report_Type := All_Reports) 2226 is 2227 procedure Internal is new Dump 2228 (Put_Line => Stdout_Put_Line, 2229 Put => Stdout_Put); 2230 2231 -- Start of processing for Dump_Stdout 2232 2233 begin 2234 Internal (Pool, Size, Report); 2235 end Dump_Stdout; 2236 2237 ----------- 2238 -- Reset -- 2239 ----------- 2240 2241 procedure Reset is 2242 Elem : Traceback_Htable_Elem_Ptr; 2243 Lock : Scope_Lock; 2244 pragma Unreferenced (Lock); 2245 begin 2246 Elem := Backtrace_Htable.Get_First; 2247 while Elem /= null loop 2248 Elem.Count := 0; 2249 Elem.Frees := 0; 2250 Elem.Total := 0; 2251 Elem.Total_Frees := 0; 2252 Elem := Backtrace_Htable.Get_Next; 2253 end loop; 2254 end Reset; 2255 2256 ------------------ 2257 -- Storage_Size -- 2258 ------------------ 2259 2260 function Storage_Size (Pool : Debug_Pool) return Storage_Count is 2261 pragma Unreferenced (Pool); 2262 begin 2263 return Storage_Count'Last; 2264 end Storage_Size; 2265 2266 --------------------- 2267 -- High_Water_Mark -- 2268 --------------------- 2269 2270 function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is 2271 Lock : Scope_Lock; 2272 pragma Unreferenced (Lock); 2273 begin 2274 return Pool.High_Water; 2275 end High_Water_Mark; 2276 2277 ------------------------ 2278 -- Current_Water_Mark -- 2279 ------------------------ 2280 2281 function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is 2282 Lock : Scope_Lock; 2283 pragma Unreferenced (Lock); 2284 begin 2285 return Pool.Allocated - Pool.Logically_Deallocated - 2286 Pool.Physically_Deallocated; 2287 end Current_Water_Mark; 2288 2289 ------------------------------ 2290 -- System_Memory_Debug_Pool -- 2291 ------------------------------ 2292 2293 procedure System_Memory_Debug_Pool 2294 (Has_Unhandled_Memory : Boolean := True) 2295 is 2296 Lock : Scope_Lock; 2297 pragma Unreferenced (Lock); 2298 begin 2299 System_Memory_Debug_Pool_Enabled := True; 2300 Allow_Unhandled_Memory := Has_Unhandled_Memory; 2301 end System_Memory_Debug_Pool; 2302 2303 --------------- 2304 -- Configure -- 2305 --------------- 2306 2307 procedure Configure 2308 (Pool : in out Debug_Pool; 2309 Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; 2310 Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; 2311 Minimum_To_Free : SSC := Default_Min_Freed; 2312 Reset_Content_On_Free : Boolean := Default_Reset_Content; 2313 Raise_Exceptions : Boolean := Default_Raise_Exceptions; 2314 Advanced_Scanning : Boolean := Default_Advanced_Scanning; 2315 Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; 2316 Low_Level_Traces : Boolean := Default_Low_Level_Traces) 2317 is 2318 Lock : Scope_Lock; 2319 pragma Unreferenced (Lock); 2320 begin 2321 Pool.Stack_Trace_Depth := Stack_Trace_Depth; 2322 Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory; 2323 Pool.Reset_Content_On_Free := Reset_Content_On_Free; 2324 Pool.Raise_Exceptions := Raise_Exceptions; 2325 Pool.Minimum_To_Free := Minimum_To_Free; 2326 Pool.Advanced_Scanning := Advanced_Scanning; 2327 Pool.Errors_To_Stdout := Errors_To_Stdout; 2328 Pool.Low_Level_Traces := Low_Level_Traces; 2329 end Configure; 2330 2331 ---------------- 2332 -- Print_Pool -- 2333 ---------------- 2334 2335 procedure Print_Pool (A : System.Address) is 2336 Storage : constant Address := A; 2337 Valid : constant Boolean := Is_Valid (Storage); 2338 Header : Allocation_Header_Access; 2339 2340 begin 2341 -- We might get Null_Address if the call from gdb was done incorrectly. 2342 -- For instance, doing a "print_pool(my_var)" passes 0x0, instead of 2343 -- passing the value of my_var. 2344 2345 if A = System.Null_Address then 2346 Put_Line 2347 (Standard_Output, "Memory not under control of the storage pool"); 2348 return; 2349 end if; 2350 2351 if not Valid then 2352 Put_Line 2353 (Standard_Output, "Memory not under control of the storage pool"); 2354 2355 else 2356 Header := Header_Of (Storage); 2357 Print_Address (Standard_Output, A); 2358 Put_Line (Standard_Output, " allocated at:"); 2359 Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); 2360 2361 if To_Traceback (Header.Dealloc_Traceback) /= null then 2362 Print_Address (Standard_Output, A); 2363 Put_Line (Standard_Output, 2364 " logically freed memory, deallocated at:"); 2365 Print_Traceback (Standard_Output, "", 2366 To_Traceback (Header.Dealloc_Traceback)); 2367 end if; 2368 end if; 2369 end Print_Pool; 2370 2371 ----------------------- 2372 -- Print_Info_Stdout -- 2373 ----------------------- 2374 2375 procedure Print_Info_Stdout 2376 (Pool : Debug_Pool; 2377 Cumulate : Boolean := False; 2378 Display_Slots : Boolean := False; 2379 Display_Leaks : Boolean := False) 2380 is 2381 procedure Internal is new Print_Info 2382 (Put_Line => Stdout_Put_Line, 2383 Put => Stdout_Put); 2384 2385 -- Start of processing for Print_Info_Stdout 2386 2387 begin 2388 Internal (Pool, Cumulate, Display_Slots, Display_Leaks); 2389 end Print_Info_Stdout; 2390 2391 ------------------ 2392 -- Dump_Gnatmem -- 2393 ------------------ 2394 2395 procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is 2396 type File_Ptr is new System.Address; 2397 2398 function fopen (Path : String; Mode : String) return File_Ptr; 2399 pragma Import (C, fopen); 2400 2401 procedure fwrite 2402 (Ptr : System.Address; 2403 Size : size_t; 2404 Nmemb : size_t; 2405 Stream : File_Ptr); 2406 2407 procedure fwrite 2408 (Str : String; 2409 Size : size_t; 2410 Nmemb : size_t; 2411 Stream : File_Ptr); 2412 pragma Import (C, fwrite); 2413 2414 procedure fputc (C : Integer; Stream : File_Ptr); 2415 pragma Import (C, fputc); 2416 2417 procedure fclose (Stream : File_Ptr); 2418 pragma Import (C, fclose); 2419 2420 Address_Size : constant size_t := 2421 System.Address'Max_Size_In_Storage_Elements; 2422 -- Size in bytes of a pointer 2423 2424 File : File_Ptr; 2425 Current : System.Address; 2426 Header : Allocation_Header_Access; 2427 Actual_Size : size_t; 2428 Num_Calls : Integer; 2429 Tracebk : Tracebacks_Array_Access; 2430 Dummy_Time : Duration := 1.0; 2431 2432 begin 2433 File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); 2434 fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); 2435 2436 fwrite 2437 (Ptr => Dummy_Time'Address, 2438 Size => Duration'Max_Size_In_Storage_Elements, 2439 Nmemb => 1, 2440 Stream => File); 2441 2442 -- List of not deallocated blocks (see Print_Info) 2443 2444 Current := Pool.First_Used_Block; 2445 while Current /= System.Null_Address loop 2446 Header := Header_Of (Current); 2447 2448 Actual_Size := size_t (Header.Block_Size); 2449 2450 if Header.Alloc_Traceback /= null then 2451 Tracebk := Header.Alloc_Traceback.Traceback; 2452 Num_Calls := Tracebk'Length; 2453 2454 -- (Code taken from memtrack.adb in GNAT's sources) 2455 2456 -- Logs allocation call using the format: 2457 2458 -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn> 2459 2460 fputc (Character'Pos ('A'), File); 2461 fwrite (Current'Address, Address_Size, 1, File); 2462 2463 fwrite 2464 (Ptr => Actual_Size'Address, 2465 Size => size_t'Max_Size_In_Storage_Elements, 2466 Nmemb => 1, 2467 Stream => File); 2468 2469 fwrite 2470 (Ptr => Dummy_Time'Address, 2471 Size => Duration'Max_Size_In_Storage_Elements, 2472 Nmemb => 1, 2473 Stream => File); 2474 2475 fwrite 2476 (Ptr => Num_Calls'Address, 2477 Size => Integer'Max_Size_In_Storage_Elements, 2478 Nmemb => 1, 2479 Stream => File); 2480 2481 for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop 2482 declare 2483 Ptr : System.Address := PC_For (Tracebk (J)); 2484 begin 2485 fwrite (Ptr'Address, Address_Size, 1, File); 2486 end; 2487 end loop; 2488 end if; 2489 2490 Current := Header.Next; 2491 end loop; 2492 2493 fclose (File); 2494 end Dump_Gnatmem; 2495 2496 ---------------- 2497 -- Stdout_Put -- 2498 ---------------- 2499 2500 procedure Stdout_Put (S : String) is 2501 begin 2502 Put (Standard_Output, S); 2503 end Stdout_Put; 2504 2505 --------------------- 2506 -- Stdout_Put_Line -- 2507 --------------------- 2508 2509 procedure Stdout_Put_Line (S : String) is 2510 begin 2511 Put_Line (Standard_Output, S); 2512 end Stdout_Put_Line; 2513 2514-- Package initialization 2515 2516begin 2517 Allocate_End; 2518 Deallocate_End; 2519 Dereference_End; 2520end GNAT.Debug_Pools; 2521