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