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