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