-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
return Tracebacks_Array_Access;
function Hash (T : Tracebacks_Array_Access) return Header;
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
- pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
+ pragma Inline (Set_Next, Next, Get_Key, Hash);
-- Subprograms required for instantiation of the htable. See GNAT.HTable.
package Backtrace_Htable is new GNAT.HTable.Static_HTable
-- Traceback_Htable_Elem_Ptr.
type Allocation_Header is record
- Block_Size : Storage_Offset;
+ Allocation_Address : System.Address;
+ -- Address of the block returned by malloc, possibly unaligned.
+
+ Block_Size : Storage_Offset;
-- Needed only for advanced freeing algorithms (traverse all allocated
-- blocks for potential references). This value is negated when the
-- chunk of memory has been logically freed by the application. This
Alloc_Traceback : Traceback_Htable_Elem_Ptr;
Dealloc_Traceback : Traceback_Ptr_Or_Address;
- -- Pointer to the traceback for the allocation (if the memory chunck is
+ -- Pointer to the traceback for the allocation (if the memory chunk is
-- still valid), or to the first deallocation otherwise. Make sure this
-- is a thin pointer to save space.
--
function To_Traceback is new Ada.Unchecked_Conversion
(Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
+ Header_Offset : constant Storage_Count
+ := Default_Alignment *
+ ((Allocation_Header'Size / System.Storage_Unit + Default_Alignment - 1)
+ / Default_Alignment);
+ -- Offset of user data after allocation header.
+
Minimum_Allocation : constant Storage_Count :=
- Default_Alignment *
- (Allocation_Header'Size /
- System.Storage_Unit /
- Default_Alignment) +
- Default_Alignment;
- -- Extra bytes to allocate to store the header. The header needs to be
- -- correctly aligned as well, so we have to allocate multiples of the
- -- alignment.
+ Default_Alignment - 1
+ + Header_Offset;
+ -- Minimal allocation: size of allocation_header rounded up to next
+ -- multiple of default alignment + worst-case padding.
-----------------------
-- Allocations table --
-----------------------
- -- This table is indexed on addresses modulo Minimum_Allocation, and
+ -- This table is indexed on addresses modulo Default_Alignment, and
-- for each index it indicates whether that memory block is valid.
-- Its behavior is similar to GNAT.Table, except that we need to pack
-- the table to save space, so we cannot reuse GNAT.Table as is.
Edata : System.Address := System.Null_Address;
-- Address in memory that matches the index 0 in Valid_Blocks. It is named
-- after the symbol _edata, which, on most systems, indicate the lowest
- -- possible address returned by malloc (). Unfortunately, this symbol
+ -- possible address returned by malloc. Unfortunately, this symbol
-- doesn't exist on windows, so we cannot use it instead of this variable.
-----------------------
function Convert is new Ada.Unchecked_Conversion
(System.Address, Allocation_Header_Access);
begin
- return Convert (Address - Minimum_Allocation);
+ return Convert (Address - Header_Offset);
end Header_Of;
--------------
function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
use Ada.Exceptions.Traceback;
-
begin
return K1.all = K2.all;
end Equal;
type Local_Storage_Array is new Storage_Array
(1 .. Size_In_Storage_Elements + Minimum_Allocation);
- for Local_Storage_Array'Alignment use Standard'Maximum_Alignment;
- -- For performance reasons, make sure the alignment is maximized.
type Ptr is access Local_Storage_Array;
-- On some systems, we might want to physically protect pages
P := new Local_Storage_Array;
end;
- Storage_Address := P.all'Address + Minimum_Allocation;
+ Storage_Address := System.Null_Address + Default_Alignment
+ * (((P.all'Address + Default_Alignment - 1) - System.Null_Address)
+ / Default_Alignment)
+ + Header_Offset;
+ pragma Assert ((Storage_Address - System.Null_Address)
+ mod Default_Alignment = 0);
+ pragma Assert (Storage_Address + Size_In_Storage_Elements
+ <= P.all'Address + P'Length);
Trace := Find_Or_Create_Traceback
(Pool, Alloc, Size_In_Storage_Elements,
-- Default_Alignment.
Header_Of (Storage_Address).all :=
- (Alloc_Traceback => Trace,
- Dealloc_Traceback => To_Traceback (null),
- Next => Pool.First_Used_Block,
- Block_Size => Size_In_Storage_Elements);
+ (Allocation_Address => P.all'Address,
+ Alloc_Traceback => Trace,
+ Dealloc_Traceback => To_Traceback (null),
+ Next => Pool.First_Used_Block,
+ Block_Size => Size_In_Storage_Elements);
pragma Warnings (On);
end if;
Unlock_Task.all;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
end Allocate;
------------------
end;
Next := Header.Next;
- System.Memory.Free (Header.all'Address);
+ System.Memory.Free (Header.Allocation_Address);
Set_Valid (Tmp, False);
-- Remove this block from the list.
end if;
Unlock_Task.all;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
end Free_Physically;
----------------
if Pool.Raise_Exceptions then
raise Freeing_Not_Allocated_Storage;
else
- Put ("Freeing not allocated storage, at ");
+ Put ("error: Freeing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
if Pool.Raise_Exceptions then
raise Freeing_Deallocated_Storage;
else
- Put ("Freeing already deallocated storage, at ");
+ Put ("error: Freeing already deallocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Deallocate_Label'Address,
Code_Address_For_Deallocate_End);
-- Update the header
Header.all :=
- (Alloc_Traceback => Header.Alloc_Traceback,
- Dealloc_Traceback => To_Traceback
- (Find_Or_Create_Traceback
- (Pool, Dealloc,
- Size_In_Storage_Elements,
- Deallocate_Label'Address,
- Code_Address_For_Deallocate_End)),
- Next => System.Null_Address,
- Block_Size => -Size_In_Storage_Elements);
+ (Allocation_Address => Header.Allocation_Address,
+ Alloc_Traceback => Header.Alloc_Traceback,
+ Dealloc_Traceback => To_Traceback
+ (Find_Or_Create_Traceback
+ (Pool, Dealloc,
+ Size_In_Storage_Elements,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End)),
+ Next => System.Null_Address,
+ Block_Size => -Size_In_Storage_Elements);
if Pool.Reset_Content_On_Free then
Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
Unlock_Task.all;
end if;
+
+ exception
+ when others =>
+ Unlock_Task.all;
+ raise;
end Deallocate;
--------------------
if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
else
- Put ("Accessing not allocated storage, at ");
+ Put ("error: Accessing not allocated storage, at ");
Put_Line (Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Code_Address_For_Dereference_End);
if Pool.Raise_Exceptions then
raise Accessing_Deallocated_Storage;
else
- Put ("Accessing deallocated storage, at ");
+ Put ("error: Accessing deallocated storage, at ");
Put_Line
(Pool.Stack_Trace_Depth, null,
Dereference_Label'Address,
Put_Line ("");
- Data := Backtrace_Htable.Get_First;
- while Data /= null loop
- if Data.Kind in Alloc .. Dealloc then
- Elem :=
- new Traceback_Htable_Elem'
- (Traceback => new Tracebacks_Array'(Data.Traceback.all),
- Count => Data.Count,
- Kind => Data.Kind,
- Total => Data.Total,
- Next => null);
- Backtrace_Htable_Cumulate.Set (Elem);
-
- if Cumulate then
- if Data.Kind = Alloc then
- K := Indirect_Alloc;
- else
- K := Indirect_Dealloc;
- end if;
+ if Display_Slots then
+ Data := Backtrace_Htable.Get_First;
+ while Data /= null loop
+ if Data.Kind in Alloc .. Dealloc then
+ Elem :=
+ new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'(Data.Traceback.all),
+ Count => Data.Count,
+ Kind => Data.Kind,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
+
+ if Cumulate then
+ if Data.Kind = Alloc then
+ K := Indirect_Alloc;
+ else
+ K := Indirect_Dealloc;
+ end if;
- -- Propagate the direct call to all its parents
+ -- Propagate the direct call to all its parents
- for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
- Elem := Backtrace_Htable_Cumulate.Get
- (Data.Traceback
- (T .. Data.Traceback'Last)'Unrestricted_Access);
+ for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
+ Elem := Backtrace_Htable_Cumulate.Get
+ (Data.Traceback
+ (T .. Data.Traceback'Last)'Unrestricted_Access);
- -- If not, insert it
+ -- If not, insert it
- if Elem = null then
- Elem := new Traceback_Htable_Elem'
- (Traceback => new Tracebacks_Array'
- (Data.Traceback (T .. Data.Traceback'Last)),
- Count => Data.Count,
- Kind => K,
- Total => Data.Total,
- Next => null);
- Backtrace_Htable_Cumulate.Set (Elem);
+ if Elem = null then
+ Elem := new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'
+ (Data.Traceback (T .. Data.Traceback'Last)),
+ Count => Data.Count,
+ Kind => K,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
- -- Properly take into account that the subprograms
- -- indirectly called might be doing either allocations
- -- or deallocations. This needs to be reflected in the
- -- counts.
+ -- Properly take into account that the subprograms
+ -- indirectly called might be doing either allocations
+ -- or deallocations. This needs to be reflected in the
+ -- counts.
- else
- Elem.Count := Elem.Count + Data.Count;
+ else
+ Elem.Count := Elem.Count + Data.Count;
- if K = Elem.Kind then
- Elem.Total := Elem.Total + Data.Total;
+ if K = Elem.Kind then
+ Elem.Total := Elem.Total + Data.Total;
- elsif Elem.Total > Data.Total then
- Elem.Total := Elem.Total - Data.Total;
+ elsif Elem.Total > Data.Total then
+ Elem.Total := Elem.Total - Data.Total;
- else
- Elem.Kind := K;
- Elem.Total := Data.Total - Elem.Total;
+ else
+ Elem.Kind := K;
+ Elem.Total := Data.Total - Elem.Total;
+ end if;
end if;
- end if;
- end loop;
- end if;
+ end loop;
+ end if;
- Data := Backtrace_Htable.Get_Next;
- end if;
- end loop;
+ Data := Backtrace_Htable.Get_Next;
+ end if;
+ end loop;
- if Display_Slots then
Put_Line ("List of allocations/deallocations: ");
Data := Backtrace_Htable_Cumulate.Get_First;
Data := Backtrace_Htable_Cumulate.Get_Next;
end loop;
+
+ Backtrace_Htable_Cumulate.Reset;
end if;
if Display_Leaks then
Current := Header.Next;
end loop;
end if;
-
- Backtrace_Htable_Cumulate.Reset;
end Print_Info;
------------------
OSDN Git Service
