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