File : s-debpoo.adb
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . D E B U G _ P O O L S --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992-1997 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Unchecked_Conversion;
with GNAT.HTable;
pragma Elaborate_All (GNAT.HTable);
package body System.Debug_Pools is
package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
use type SSE.Integer_Address;
-- Definition of a H-table storing the status of each storage chunck
-- used by this pool
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 => "=");
-------
-- H --
-------
function H (F : Address) return Header is
begin
return Header (1 +
(SSE.To_Integer (F) mod SSE.Integer_Address (Header'Last)));
end H;
--------------
-- Allocate --
--------------
procedure Allocate
(Pool : in out Debug_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : in SSE.Storage_Count;
Alignment : in SSE.Storage_Count)
is
function Malloc (Size : SSE.Storage_Count) return System.Address;
pragma Import (C, Malloc, "__gnat_malloc");
begin
Storage_Address := Malloc (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;
----------------
-- Deallocate --
----------------
procedure Deallocate
(Pool : in out Debug_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in SSE.Storage_Count;
Alignment : in SSE.Storage_Count)
is
procedure Free (Address : System.Address; Siz : SSE.Storage_Count);
-- Faked free, that reset all the deallocated storage to "DEADBEEF"
procedure Free (Address : System.Address; Siz : SSE.Storage_Count) is
DB : constant SSE.Storage_Array (0 .. 3) :=
(16#DE#, 16#AD#, 16#BE#, 16#EF#);
DB_Index : SSE.Storage_Offset := DB'First;
subtype Dead_Memory is SSE.Storage_Array (1 .. Siz);
type Mem_Ptr is access all Dead_Memory;
function From_Ptr is
new Unchecked_Conversion (System.Address, Mem_Ptr);
begin
for J in Dead_Memory'Range loop
From_Ptr (Address) (J) := DB (DB_Index);
DB_Index := SSE.Storage_Offset'(DB_Index + 1) mod (DB'Last + 1);
end loop;
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;
------------------
-- Storage_Size --
------------------
function Storage_Size (Pool : Debug_Pool) return SSE.Storage_Count is
begin
return SSE.Storage_Count'Last;
end Storage_Size;
-----------------
-- Dereference --
-----------------
procedure Dereference
(Pool : in out Debug_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in SSE.Storage_Count;
Alignment : in SSE.Storage_Count)
is
S : State := Table.Get (Storage_Address);
begin
case S is
when Not_Allocated =>
raise Accessing_Not_Allocated_Storage;
when Deallocated =>
raise Accessing_Deallocated_Storage;
when Allocated =>
null;
end case;
end Dereference;
----------------
-- Print_Info --
----------------
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;
end System.Debug_Pools;