with Unchecked_Conversion;
with GNAT.HTable;
with System.Memory;
pragma Elaborate_All (GNAT.HTable);
package body GNAT.Debug_Pools is
use System;
use System.Memory;
use System.Storage_Elements;
type State is (Not_Allocated, Deallocated, Allocated);
type Header is range 1 .. 1023;
function H (F : Address) return Header;
package Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header,
Element => State,
No_Element => Not_Allocated,
Key => Address,
Hash => H,
Equal => "=");
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
pragma Warnings (Off, Alignment);
begin
Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
if Storage_Address = Null_Address then
raise Storage_Error;
else
Table.Set (Storage_Address, Allocated);
Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
if Pool.Allocated - Pool.Deallocated > Pool.High_Water then
Pool.High_Water := Pool.Allocated - Pool.Deallocated;
end if;
end if;
end Allocate;
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
pragma Warnings (Off, Alignment);
procedure Free (Address : System.Address; Siz : Storage_Count);
procedure Free (Address : System.Address; Siz : Storage_Count) is
DB1 : constant Integer := 16#DEAD#;
DB2 : constant Integer := 16#BEEF#;
type Dead_Memory is array (1 .. Siz / 4) of Integer;
type Mem_Ptr is access all Dead_Memory;
function From_Ptr is
new Unchecked_Conversion (System.Address, Mem_Ptr);
J : Storage_Offset;
begin
J := Dead_Memory'First;
while J < Dead_Memory'Last loop
From_Ptr (Address) (J) := DB1;
From_Ptr (Address) (J + 1) := DB2;
J := J + 2;
end loop;
if J = Dead_Memory'Last then
From_Ptr (Address) (J) := DB1;
end if;
end Free;
S : State := Table.Get (Storage_Address);
begin
case S is
when Not_Allocated =>
raise Freeing_Not_Allocated_Storage;
when Deallocated =>
raise Freeing_Deallocated_Storage;
when Allocated =>
Free (Storage_Address, Size_In_Storage_Elements);
Table.Set (Storage_Address, Deallocated);
Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
end case;
end Deallocate;
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : Address;
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
pragma Warnings (Off, Pool);
pragma Warnings (Off, Size_In_Storage_Elements);
pragma Warnings (Off, Alignment);
S : State := Table.Get (Storage_Address);
Max_Dim : constant := 3;
Dim : Integer := 1;
begin
while S = Not_Allocated and then Dim <= Max_Dim loop
S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
Dim := Dim + 1;
end loop;
case S is
when Not_Allocated =>
raise Accessing_Not_Allocated_Storage;
when Deallocated =>
raise Accessing_Deallocated_Storage;
when Allocated =>
null;
end case;
end Dereference;
function H (F : Address) return Header is
begin
return
Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
end H;
procedure Print_Info (Pool : Debug_Pool) is
use System.Storage_Elements;
begin
Put_Line ("Debug Pool info:");
Put_Line (" Total allocated bytes : "
& Storage_Offset'Image (Pool.Allocated));
Put_Line (" Total deallocated bytes : "
& Storage_Offset'Image (Pool.Deallocated));
Put_Line (" Current Water Mark: "
& Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
Put_Line (" High Water Mark: "
& Storage_Offset'Image (Pool.High_Water));
Put_Line ("");
end Print_Info;
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
pragma Warnings (Off, Pool);
begin
return Storage_Count'Last;
end Storage_Size;
end GNAT.Debug_Pools;