Skip to content

R
riscv-gcc-1
Commit 11f03980 by Vincent Celier Committed by Arnaud Charlet
Options

g-debpoo.adb (Validity): New package with a complete new implementation of… 

g-debpoo.adb (Validity): New package with a complete new implementation of subprograms Is_Valid and...

2007-04-06  Vincent Celier  <celier@adacore.com>

	* g-debpoo.adb (Validity): New package with a complete new
	implementation of subprograms Is_Valid and Set_Valid.
	(Is_Valid): Move to local package Validity
	(Set_Valid): Move to local package Validity

From-SVN: r123572
parent 358f47f3
Showing with 139 additions and 202 deletions
gcc/ada/g-debpoo.adb
...@@ -53,12 +53,6 @@ package body GNAT.Debug_Pools is ...@@ -53,12 +53,6 @@ package body GNAT.Debug_Pools is
-- and at the same time makes it easy to find the location of the extra -- and at the same time makes it easy to find the location of the extra
-- header allocated for each chunk. -- header allocated for each chunk.
Initial_Memory_Size : constant Storage_Offset := 2 ** 26; -- 64 Mb
-- Initial size of memory that the debug pool can handle. This is used to
-- compute the size of the htable used to monitor the blocks, but this is
-- dynamic and will grow as needed. Having a bigger size here means a
-- longer setup time, but less time spent later on to grow the array.
Max_Ignored_Levels : constant Natural := 10; Max_Ignored_Levels : constant Natural := 10;
-- Maximum number of levels that will be ignored in backtraces. This is so -- Maximum number of levels that will be ignored in backtraces. This is so
-- that we still have enough significant levels in the tracebacks returned -- that we still have enough significant levels in the tracebacks returned
...@@ -211,64 +205,6 @@ package body GNAT.Debug_Pools is ...@@ -211,64 +205,6 @@ package body GNAT.Debug_Pools is
-- multiple of default alignment + worst-case padding. -- multiple of default alignment + worst-case padding.
----------------------- -----------------------
-- Allocations table --
-----------------------
-- 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.
-- This table is the reason why all alignments have to be forced to common
-- value (Default_Alignment), so that this table can be kept to a
-- reasonnable size.
type Byte is mod 2 ** System.Storage_Unit;
Big_Table_Size : constant Storage_Offset :=
(Storage_Offset'Last - 1) / Default_Alignment;
type Big_Table is array (0 .. Big_Table_Size) of Byte;
-- A simple, flat-array type used to access memory bytes (see the comment
-- for Valid_Blocks below).
--
-- It would be cleaner to represent this as a packed array of Boolean.
-- However, we cannot specify pragma Pack for such an array, since the
-- total size on a 64 bit machine would be too big (> Integer'Last).
--
-- Given an address, we know if it is under control of the debug pool if
-- the byte at index:
-- ((Address - Edata'Address) / Default_Alignment)
-- / Storage_unit
-- has the bit
-- ((Address - Edata'Address) / Default_Alignment)
-- mod Storage_Unit
-- set to 1.
--
-- See the subprograms Is_Valid and Set_Valid for proper manipulation of
-- this array.
type Table_Ptr is access Big_Table;
function To_Pointer is new Ada.Unchecked_Conversion
(System.Address, Table_Ptr);
Valid_Blocks : Table_Ptr := null;
Valid_Blocks_Size : Storage_Offset := 0;
-- These two variables represents a mapping of the currently allocated
-- memory. Every time the pool works on an address, we first check that the
-- index Address / Default_Alignment is True. If not, this means that this
-- address is not under control of the debug pool and thus this is probably
-- an invalid memory access (it could also be a general access type).
--
-- Note that in fact we never allocate the full size of Big_Table, only a
-- slice big enough to manage the currently allocated memory.
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 doesn't
-- exist on windows, so we cannot use it instead of this variable.
-----------------------
-- Local subprograms -- -- Local subprograms --
----------------------- -----------------------
...@@ -297,16 +233,19 @@ package body GNAT.Debug_Pools is ...@@ -297,16 +233,19 @@ package body GNAT.Debug_Pools is
-- addresses up to the first one in the range -- addresses up to the first one in the range
-- Ignored_Frame_Start .. Ignored_Frame_End -- Ignored_Frame_Start .. Ignored_Frame_End
function Is_Valid (Storage : System.Address) return Boolean; package Validity is
pragma Inline (Is_Valid); function Is_Valid (Storage : System.Address) return Boolean;
-- Return True if Storage is an address that the debug pool has under its pragma Inline (Is_Valid);
-- control. -- Return True if Storage is an address that the debug pool has under
-- its control.
procedure Set_Valid (Storage : System.Address; Value : Boolean); procedure Set_Valid (Storage : System.Address; Value : Boolean);
pragma Inline (Set_Valid); pragma Inline (Set_Valid);
-- Mark the address Storage as being under control of the memory pool (if -- Mark the address Storage as being under control of the memory pool
-- Value is True), or not (if Value is False). This procedure will -- (if Value is True), or not (if Value is False).
-- reallocate the table Valid_Blocks as needed. end Validity;
use Validity;
procedure Set_Dead_Beef procedure Set_Dead_Beef
(Storage_Address : System.Address; (Storage_Address : System.Address;
...@@ -551,143 +490,129 @@ package body GNAT.Debug_Pools is ...@@ -551,143 +490,129 @@ package body GNAT.Debug_Pools is
end Find_Or_Create_Traceback; end Find_Or_Create_Traceback;
-------------- --------------
-- Is_Valid -- -- Validity --
-------------- --------------
function Is_Valid (Storage : System.Address) return Boolean is package body Validity is
-- We use the following constant declaration, instead of -- The validity bits of the allocated blocks are kept in a has table.
-- Offset : constant Storage_Offset := -- Each component of the hash table contains the validity bits for a
-- (Storage - Edata) / Default_Alignment; -- 16 Mbyte memory chunk.
-- See comments in Set_Valid for details.
Offset : constant Storage_Offset := -- The reason the validity bits are kept for chunks of memory rather
Storage_Offset ((To_Integer (Storage) - To_Integer (Edata)) / -- than in a big array is that on some 64 bit platforms, it may happen
Default_Alignment); -- that two chunk of allocated data are very far from each other.
Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB
Validity_Divisor : constant := Default_Alignment * System.Storage_Unit;
begin Max_Validity_Byte_Index : constant :=
return (Storage mod Default_Alignment) = 0 Memory_Chunk_Size / Validity_Divisor;
and then Offset >= 0
and then Offset < Valid_Blocks_Size * Storage_Unit
and then (Valid_Blocks (Offset / Storage_Unit) and Bit) /= 0;
end Is_Valid;
--------------- subtype Validity_Byte_Index is Integer_Address
-- Set_Valid -- range 0 .. Max_Validity_Byte_Index - 1;
---------------
procedure Set_Valid (Storage : System.Address; Value : Boolean) is type Byte is mod 2 ** System.Storage_Unit;
Offset : Storage_Offset;
Bit : Byte;
Bytes : Storage_Offset;
Tmp : constant Table_Ptr := Valid_Blocks;
Edata_Align : constant Storage_Offset := type Validity_Bits is array (Validity_Byte_Index) of Byte;
Default_Alignment * Storage_Unit;
procedure Memset (A : Address; C : Integer; N : size_t); type Validity_Bits_Ref is access all Validity_Bits;
pragma Import (C, Memset, "memset"); No_Validity_Bits : constant Validity_Bits_Ref := null;
procedure Memmove (Dest, Src : Address; N : size_t); Max_Header_Num : constant := 1023;
pragma Import (C, Memmove, "memmove");
begin type Header_Num is range 0 .. Max_Header_Num - 1;
-- Allocate, or reallocate, the valid blocks table as needed. We start
-- with a size big enough to handle Initial_Memory_Size bytes of memory,
-- to avoid too many reallocations. The table will typically be around
-- 16Mb in that case, which is still small enough.
if Valid_Blocks_Size = 0 then function Hash (F : Integer_Address) return Header_Num;
Valid_Blocks_Size := (Initial_Memory_Size / Default_Alignment)
/ Storage_Unit;
Valid_Blocks := To_Pointer (Alloc (size_t (Valid_Blocks_Size)));
Edata := Storage;
-- Reset the memory using memset, which is much faster than the package Validy_Htable is new GNAT.HTable.Simple_HTable
-- standard Ada code with "when others" (Header_Num => Header_Num,
Element => Validity_Bits_Ref,
Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size)); No_Element => No_Validity_Bits,
end if; Key => Integer_Address,
Hash => Hash,
-- First case : the new address is outside of the current scope of Equal => "=");
-- Valid_Blocks, before the current start address. We need to reallocate -- Table to keep the validity bit blocks for the allocated data
-- the table accordingly. This should be a rare occurence, since in most
-- cases, the first allocation will also have the lowest address. But
-- there is no garantee...
if Storage < Edata then
-- The difference between the new Edata and the current one must be
-- a multiple of Default_Alignment * Storage_Unit, so that the bit
-- representing an address in Valid_Blocks are kept the same.
Offset := ((Edata - Storage) / Edata_Align + 1) * Edata_Align;
Offset := Offset / Default_Alignment;
Bytes := Offset / Storage_Unit;
Valid_Blocks :=
To_Pointer (Alloc (Size => size_t (Valid_Blocks_Size + Bytes)));
Memmove (Dest => Valid_Blocks.all'Address + Bytes,
Src => Tmp.all'Address,
N => size_t (Valid_Blocks_Size));
Memset (A => Valid_Blocks.all'Address,
C => 0,
N => size_t (Bytes));
Free (Tmp.all'Address);
Valid_Blocks_Size := Valid_Blocks_Size + Bytes;
-- Take into the account the new start address
Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align;
end if;
-- Second case : the new address is outside of the current scope of function To_Pointer is new Ada.Unchecked_Conversion
-- Valid_Blocks, so we have to grow the table as appropriate. (System.Address, Validity_Bits_Ref);
-- Note: it might seem more natural for the following statement to procedure Memset (A : Address; C : Integer; N : size_t);
-- be written: pragma Import (C, Memset, "memset");
-- Offset := (Storage - Edata) / Default_Alignment; ----------
-- Hash --
----------
-- but that won't work since Storage_Offset is signed, and it is function Hash (F : Integer_Address) return Header_Num is
-- possible to subtract a small address from a large address and begin
-- get a negative value. This may seem strange, but it is quite return Header_Num (F mod Max_Header_Num);
-- specifically allowed in the RM, and is what most implementations end Hash;
-- including GNAT actually do. Hence the conversion to Integer_Address
-- which is a full range modular type, not subject to this glitch. --------------
-- Is_Valid --
--------------
function Is_Valid (Storage : System.Address) return Boolean is
Int_Storage : constant Integer_Address := To_Integer (Storage);
Block_Number : constant Integer_Address :=
Int_Storage / Memory_Chunk_Size;
Ptr : constant Validity_Bits_Ref :=
Validy_Htable.Get (Block_Number);
Offset : constant Integer_Address :=
(Int_Storage - (Block_Number * Memory_Chunk_Size)) /
Default_Alignment;
Bit : constant Byte :=
2 ** Natural (Offset mod System.Storage_Unit);
begin
if Ptr = No_Validity_Bits then
return False;
else
return (Ptr (Offset / System.Storage_Unit) and Bit) /= 0;
end if;
end Is_Valid;
---------------
-- Set_Valid --
---------------
procedure Set_Valid (Storage : System.Address; Value : Boolean) is
Int_Storage : constant Integer_Address := To_Integer (Storage);
Block_Number : constant Integer_Address :=
Int_Storage / Memory_Chunk_Size;
Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number);
Offset : constant Integer_Address :=
(Int_Storage - (Block_Number * Memory_Chunk_Size)) /
Default_Alignment;
Bit : constant Byte :=
2 ** Natural (Offset mod System.Storage_Unit);
Offset := Storage_Offset ((To_Integer (Storage) - To_Integer (Edata)) / begin
Default_Alignment); if Ptr = No_Validity_Bits then
if Offset >= Valid_Blocks_Size * System.Storage_Unit then -- First time in this memory area: allocate a new block and put
Bytes := Valid_Blocks_Size; -- it in the table.
loop
Bytes := 2 * Bytes;
exit when Offset <= Bytes * System.Storage_Unit;
end loop;
Valid_Blocks := To_Pointer if Value then
(Realloc (Ptr => Valid_Blocks.all'Address, Ptr := To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
Size => size_t (Bytes))); Validy_Htable.Set (Block_Number, Ptr);
Memset Memset (Ptr.all'Address, 0, size_t (Max_Validity_Byte_Index));
(Valid_Blocks.all'Address + Valid_Blocks_Size, Ptr (Offset / System.Storage_Unit) := Bit;
0, end if;
size_t (Bytes - Valid_Blocks_Size));
Valid_Blocks_Size := Bytes;
end if;
Bit := 2 ** Natural (Offset mod System.Storage_Unit); else
Bytes := Offset / Storage_Unit; if Value then
Ptr (Offset / System.Storage_Unit) :=
Ptr (Offset / System.Storage_Unit) or Bit;
-- Then set the value as valid else
Ptr (Offset / System.Storage_Unit) :=
Ptr (Offset / System.Storage_Unit) and (not Bit);
end if;
end if;
end Set_Valid;
if Value then end Validity;
Valid_Blocks (Bytes) := Valid_Blocks (Bytes) or Bit;
else
Valid_Blocks (Bytes) := Valid_Blocks (Bytes) and (not Bit);
end if;
end Set_Valid;
-------------- --------------
-- Allocate -- -- Allocate --
...@@ -706,11 +631,10 @@ package body GNAT.Debug_Pools is ...@@ -706,11 +631,10 @@ package body GNAT.Debug_Pools is
(1 .. Size_In_Storage_Elements + Minimum_Allocation); (1 .. Size_In_Storage_Elements + Minimum_Allocation);
type Ptr is access Local_Storage_Array; type Ptr is access Local_Storage_Array;
-- On some systems, we might want to physically protect pages -- On some systems, we might want to physically protect pages against
-- against writing when they have been freed (of course, this is -- writing when they have been freed (of course, this is expensive in
-- expensive in terms of wasted memory). To do that, all we should -- terms of wasted memory). To do that, all we should have to do it to
-- have to do it to set the size of this array to the page size. -- set the size of this array to the page size. See mprotect().
-- See mprotect().
P : Ptr; P : Ptr;
...@@ -723,10 +647,10 @@ package body GNAT.Debug_Pools is ...@@ -723,10 +647,10 @@ package body GNAT.Debug_Pools is
-- If necessary, start physically releasing memory. The reason this is -- If necessary, start physically releasing memory. The reason this is
-- done here, although Pool.Logically_Deallocated has not changed above, -- done here, although Pool.Logically_Deallocated has not changed above,
-- is so that we do this only after a series of deallocations (e.g a -- is so that we do this only after a series of deallocations (e.g loop
-- loop that deallocates a big array). If we were doing that in -- that deallocates a big array). If we were doing that in Deallocate,
-- Deallocate, we might be physically freeing memory several times -- we might be physically freeing memory several times during the loop,
-- during the loop, which is expensive. -- which is expensive.
if Pool.Logically_Deallocated > if Pool.Logically_Deallocated >
Byte_Count (Pool.Maximum_Logically_Freed_Memory) Byte_Count (Pool.Maximum_Logically_Freed_Memory)
...@@ -764,8 +688,8 @@ package body GNAT.Debug_Pools is ...@@ -764,8 +688,8 @@ package body GNAT.Debug_Pools is
Allocate_Label'Address, Code_Address_For_Allocate_End); Allocate_Label'Address, Code_Address_For_Allocate_End);
pragma Warnings (Off); pragma Warnings (Off);
-- Turn warning on alignment for convert call off. We know that in -- Turn warning on alignment for convert call off. We know that in fact
-- fact this conversion is safe since P itself is always aligned on -- this conversion is safe since P itself is always aligned on
-- Default_Alignment. -- Default_Alignment.
Header_Of (Storage_Address).all := Header_Of (Storage_Address).all :=
...@@ -822,9 +746,9 @@ package body GNAT.Debug_Pools is ...@@ -822,9 +746,9 @@ package body GNAT.Debug_Pools is
-- Allocate_End -- -- Allocate_End --
------------------ ------------------
-- DO NOT MOVE, this must be right after Allocate. This is similar to -- DO NOT MOVE, this must be right after Allocate. This is similar to what
-- what is done in a-except, so that we can hide the traceback frames -- is done in a-except, so that we can hide the traceback frames internal
-- internal to this package -- to this package
procedure Allocate_End is procedure Allocate_End is
begin begin
...@@ -946,7 +870,7 @@ package body GNAT.Debug_Pools is ...@@ -946,7 +870,7 @@ package body GNAT.Debug_Pools is
Header := Header_Of (Tmp); Header := Header_Of (Tmp);
-- If we know, or at least assume, the block is no longer -- If we know, or at least assume, the block is no longer
-- reference anywhere, we can free it physically. -- referenced anywhere, we can free it physically.
if Ignore_Marks or else not Marked (Tmp) then if Ignore_Marks or else not Marked (Tmp) then
...@@ -1043,6 +967,7 @@ package body GNAT.Debug_Pools is ...@@ -1043,6 +967,7 @@ package body GNAT.Debug_Pools is
-- Do not even attempt to mark blocks in use. That would -- Do not even attempt to mark blocks in use. That would
-- screw up the whole application, of course. -- screw up the whole application, of course.
if Header.Block_Size < 0 then if Header.Block_Size < 0 then
Mark (Header, Pointed, In_Use => True); Mark (Header, Pointed, In_Use => True);
end if; end if;
...@@ -1085,7 +1010,11 @@ package body GNAT.Debug_Pools is ...@@ -1085,7 +1010,11 @@ package body GNAT.Debug_Pools is
Lock_Task.all; Lock_Task.all;
if Pool.Advanced_Scanning then if Pool.Advanced_Scanning then
Reset_Marks; -- Reset the mark for each freed block
-- Reset the mark for each freed block
Reset_Marks;
Mark_Blocks; Mark_Blocks;
end if; end if;
...@@ -1232,8 +1161,11 @@ package body GNAT.Debug_Pools is ...@@ -1232,8 +1161,11 @@ package body GNAT.Debug_Pools is
-------------------- --------------------
-- DO NOT MOVE, this must be right after Deallocate -- DO NOT MOVE, this must be right after Deallocate
-- See Allocate_End -- See Allocate_End
-- This is making assumptions about code order that may be invalid ???
procedure Deallocate_End is procedure Deallocate_End is
begin begin
<<Deallocate_End_Label>> <<Deallocate_End_Label>>
...@@ -1301,8 +1233,11 @@ package body GNAT.Debug_Pools is ...@@ -1301,8 +1233,11 @@ package body GNAT.Debug_Pools is
--------------------- ---------------------
-- DO NOT MOVE: this must be right after Dereference -- DO NOT MOVE: this must be right after Dereference
-- See Allocate_End -- See Allocate_End
-- This is making assumptions about code order that may be invalid ???
procedure Dereference_End is procedure Dereference_End is
begin begin
<<Dereference_End_Label>> <<Dereference_End_Label>>
...@@ -1651,6 +1586,8 @@ package body GNAT.Debug_Pools is ...@@ -1651,6 +1586,8 @@ package body GNAT.Debug_Pools is
fclose (File); fclose (File);
end Dump_Gnatmem; end Dump_Gnatmem;
-- Package initialization
begin begin
Allocate_End; Allocate_End;
Deallocate_End; Deallocate_End;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment