-- Copyright 1994 Grady Booch
-- Copyright 1999 Pat Rogers
-- Copyright 1999-2002 Simon Wright <simon@pushface.org>
-- This package is free software; you can redistribute it and/or
-- modify it under terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2, or
-- (at your option) any later version. This package is distributed in
-- the hope that it will be useful, but WITHOUT 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 this package; 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.
-- $RCSfile: bc-support-managed_storage.adb,v $
-- $Revision: 1.12.2.1 $
-- $Date: 2002/12/26 14:48:14 $
-- $Author: simon $
with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;
package body BC.Support.Managed_Storage is
procedure Assert
is new BC.Support.Exceptions.Assert ("BC.Support.Managed_Storage");
package PeekPoke is
new System.Address_To_Access_Conversions (System.Address);
function Value_At (Location : System.Address) return System.Address;
procedure Put (This : System.Address; At_Location : System.Address);
pragma Inline (Value_At, Put);
function Value_At (Location : System.Address) return System.Address is
begin
return PeekPoke.To_Pointer (Location).all;
end Value_At;
procedure Put (This : System.Address;
At_Location : System.Address) is
begin
PeekPoke.To_Pointer (At_Location).all := This;
end Put;
procedure Dispose is
new Ada.Unchecked_Deallocation (Chunk, Chunk_Pointer);
procedure Initialize (This : in out Pool) is
begin
This.Allocated_Chunk_Size :=
Aligned (This.Chunk_Size, System.Word_Size / System.Storage_Unit);
end Initialize;
procedure Finalize (This : in out Pool) is
Temp, Chunk, Ptr : Chunk_Pointer;
begin
Purge_Unused_Chunks (This);
Ptr := This.Head;
while Ptr /= null loop
Chunk := Ptr;
Ptr := Ptr.Next_Sized_Chunk;
while Chunk /= null loop
Temp := Chunk;
Chunk := Chunk.Next_Chunk;
Dispose (Temp);
end loop;
end loop;
end Finalize;
function New_Allocation (Size : SSE.Storage_Count) return Chunk_Pointer is
begin
return new Chunk (Size - Pool_Overhead (Alignment => 1));
end New_Allocation;
function Pool_Overhead
(Type_Overhead : SSE.Storage_Count := 0;
Alignment : SSE.Storage_Count) return SSE.Storage_Count is
begin
return Aligned (Chunk_Overhead + Type_Overhead, Alignment);
end Pool_Overhead;
procedure Get_Chunk (Result : out Chunk_Pointer;
From : in out Pool;
Requested_Element_Size : SSE.Storage_Count;
Requested_Alignment : SSE.Storage_Count) is
Next, Start, Stop : System.Address;
Usable_Chunk_Size : SSE.Storage_Count;
use type System.Address;
begin
Usable_Chunk_Size :=
From.Allocated_Chunk_Size - Aligned (Chunk_Overhead,
Requested_Alignment);
Assert (Requested_Element_Size <= Usable_Chunk_Size,
BC.Storage_Error'Identity,
"Get_Chunk",
BC.Support.Exceptions.Out_Of_Memory);
if From.Unused /= null then
Result := From.Unused;
From.Unused := From.Unused.Next_Chunk;
else
Result := New_Allocation (From.Allocated_Chunk_Size);
end if;
Result.Element_Size := Requested_Element_Size;
Result.Alignment := Requested_Alignment;
Result.Number_Elements := Usable_Chunk_Size / Requested_Element_Size;
Start := Result.all'Address
+ Aligned (Chunk_Overhead, Requested_Alignment);
Stop := Start + ((Result.Number_Elements - 1) * Result.Element_Size);
Next := Start;
while Next < Stop loop
Put (Next + Requested_Element_Size, At_Location => Next);
Next := Next + Requested_Element_Size;
end loop;
Put (System.Null_Address, At_Location => Stop);
Result.Next_Element := Start;
end Get_Chunk;
procedure Allocate (The_Pool : in out Pool;
Storage_Address : out System.Address;
Size_In_Storage_Elements : SSE.Storage_Count;
Alignment : SSE.Storage_Count) is
Ptr : Chunk_Pointer;
Aligned_Size : SSE.Storage_Offset;
Previous : Chunk_Pointer;
Temp : Chunk_Pointer;
use type System.Address;
begin
Aligned_Size := Aligned (Size_In_Storage_Elements, Alignment);
if Aligned_Size = 0 then
raise Storage_Error;
end if;
-- look for a chunk with the right element size and alignment,
-- stopping when no point in continuing
Ptr := The_Pool.Head;
while Ptr /= null and then
(Aligned_Size > Ptr.Element_Size or Ptr.Alignment /= Alignment)
loop
Previous := Ptr;
Ptr := Ptr.Next_Sized_Chunk;
end loop;
if Ptr = null then -- didn't find one
Get_Chunk (Ptr, The_Pool, Aligned_Size, Alignment);
if Previous /= null then
Previous.Next_Sized_Chunk := Ptr;
else -- last was empty
The_Pool.Head := Ptr;
end if;
Ptr.Previous_Sized_Chunk := Previous;
-- null or predecessor sized chunk
Ptr.Next_Sized_Chunk := null;
-- because chunks are reused when possible
Ptr.Next_Chunk := null;
-- because chunks are reused when possible
elsif (Aligned_Size /= Ptr.Element_Size)
or (Ptr.Next_Element = System.Null_Address) then
Get_Chunk (Temp, The_Pool, Aligned_Size, Alignment);
if Previous /= null then -- list wasn't empty
Previous.Next_Sized_Chunk := Temp;
else
The_Pool.Head := Temp;
end if;
Temp.Previous_Sized_Chunk := Previous;
if Aligned_Size /= Ptr.Element_Size then
Ptr.Previous_Sized_Chunk := Temp;
Temp.Next_Sized_Chunk := Ptr;
Temp.Next_Chunk := null;
elsif Ptr.Next_Element = System.Null_Address then
Temp.Next_Sized_Chunk := Ptr.Next_Sized_Chunk;
Temp.Next_Chunk := Ptr;
end if;
Ptr := Temp;
end if;
Storage_Address := Ptr.Next_Element;
Ptr.Next_Element := Value_At (Ptr.Next_Element);
end Allocate;
procedure Deallocate
(The_Pool : in out Pool;
Storage_Address : System.Address;
Size_In_Storage_Elements : SSE.Storage_Count;
Alignment : SSE.Storage_Count) is
Aligned_Size : SSE.Storage_Offset;
Ptr : Chunk_Pointer;
begin
Aligned_Size := Aligned (Size_In_Storage_Elements, Alignment);
if Aligned_Size = 0 then
return;
end if;
Ptr := The_Pool.Head;
while Ptr /= null and then
(Aligned_Size /= Ptr.Element_Size or Ptr.Alignment /= Alignment)
loop
Ptr := Ptr.Next_Sized_Chunk;
end loop;
Put (Ptr.Next_Element, At_Location => Storage_Address);
Ptr.Next_Element := Storage_Address;
-- Note that the effect of the above is that the "linked list" of
-- elements will span chunks. This is necessary since Deallocate
-- is given an address of the element, not a pointer to the
-- containing chunk.
end Deallocate;
function Storage_Size (This : Pool) return SSE.Storage_Count is
pragma Warnings (Off, This);
begin
return SSE.Storage_Count'Last; -- well, what else can we say!?
end Storage_Size;
procedure Preallocate_Chunks (This : in out Pool; Count : Positive) is
Ptr : Chunk_Pointer;
begin
for K in 1 .. Count loop
Ptr := New_Allocation (This.Allocated_Chunk_Size);
Ptr.Next_Chunk := This.Unused;
This.Unused := Ptr;
end loop;
end Preallocate_Chunks;
function Within_Range (Target : System.Address;
Base : Chunk_Pointer;
Offset : SSE.Storage_Count) return Boolean is
use type System.Address;
begin
return Base.all'Address <= Target and Target < Base.all'Address + Offset;
end Within_Range;
procedure Reclaim_Unused_Chunks (This : in out Pool) is
Ptr : Chunk_Pointer;
Previous : Chunk_Pointer;
Chunk : Chunk_Pointer;
Temp : Chunk_Pointer;
Next_Chunk : Chunk_Pointer;
Previous_Chunk : Chunk_Pointer;
Usable_Chunk_Size : SSE.Storage_Count;
Element : System.Address;
use SSE;
use type System.Address;
begin
pragma Style_Checks (Off); -- GNAT 3.14a mishandles named loops
Ptr := This.Head;
while Ptr /= null loop
Chunk := Ptr;
-- Compute the maximum number of elements possible, per chunk,
-- within this sized sublist.
Compute_Max :
while Chunk /= null loop
Usable_Chunk_Size :=
This.Allocated_Chunk_Size - Aligned (Chunk_Overhead,
Chunk.Alignment);
Chunk.Number_Elements := Usable_Chunk_Size / Chunk.Element_Size;
Chunk := Chunk.Next_Chunk;
end loop Compute_Max;
-- Now we traverse the "linked list" of elements that span
-- chunks, determining the containing chunk per element and
-- decrementing the corresponding count (computed as the max,
-- above).
Element := Ptr.Next_Element;
Decrement_Counts :
while Element /= System.Null_Address loop
Chunk := Ptr;
This_Chunk :
while Chunk /= null loop
if Within_Range (Element,
Base => Chunk,
Offset => This.Chunk_Size) then
Chunk.Number_Elements := Chunk.Number_Elements - 1;
exit This_Chunk;
-- stay with this chunk and check next element
end if;
Chunk := Chunk.Next_Chunk;
end loop This_Chunk;
Element := Value_At (Element); -- get next element
end loop Decrement_Counts;
-- Now walk each sized sublist and remove those no longer used.
Previous_Chunk := null;
Chunk := Ptr;
Reclaiming :
while Chunk /= null loop
if Chunk.Number_Elements = 0 then -- remove it
if Previous_Chunk /= null then
Previous_Chunk.Next_Chunk := Chunk.Next_Chunk;
Chunk.Next_Chunk := This.Unused;
This.Unused := Chunk;
Chunk := Previous_Chunk.Next_Chunk;
else
Temp := Chunk.Next_Chunk;
Next_Chunk := Chunk.Next_Sized_Chunk;
if Temp /= null then
if Previous /= null then
Previous.Next_Sized_Chunk := Temp;
else
This.Head := Temp;
end if;
Temp.Previous_Sized_Chunk := Previous;
Temp.Next_Sized_Chunk := Next_Chunk;
Temp.Next_Element := Chunk.Next_Element;
else
if Previous /= null then
Previous.Next_Sized_Chunk := Next_Chunk;
else
This.Head := Next_Chunk;
end if;
end if;
if Next_Chunk /= null then
if Temp /= null then
Next_Chunk.Previous_Sized_Chunk := Temp;
else
Next_Chunk.Previous_Sized_Chunk := Previous;
end if;
end if;
Chunk.Next_Chunk := This.Unused;
This.Unused := Chunk;
Chunk := Temp;
end if;
else
Previous_Chunk := Chunk;
Chunk := Chunk.Next_Chunk;
end if;
end loop Reclaiming;
Previous := Ptr;
Ptr := Ptr.Next_Sized_Chunk;
end loop;
pragma Style_Checks (On);
end Reclaim_Unused_Chunks;
procedure Purge_Unused_Chunks (This : in out Pool) is
Current : Chunk_Pointer;
begin
while This.Unused /= null loop
Current := This.Unused;
This.Unused := This.Unused.Next_Chunk;
Dispose (Current);
end loop;
end Purge_Unused_Chunks;
function Total_Chunks (This : Pool) return Natural is
begin
return Dirty_Chunks (This) + Unused_Chunks (This);
end Total_Chunks;
function Dirty_Chunks (This : Pool) return Natural is
Result : Natural := 0;
All_Chunks : Chunk_Pointer;
Sized_Chunk : Chunk_Pointer;
begin
All_Chunks := This.Head;
while All_Chunks /= null loop
Sized_Chunk := All_Chunks;
All_Chunks := All_Chunks.Next_Sized_Chunk;
while Sized_Chunk /= null loop
Result := Result + 1;
Sized_Chunk := Sized_Chunk.Next_Chunk;
end loop;
end loop;
return Result;
end Dirty_Chunks;
function Unused_Chunks (This : Pool) return Natural is
Ptr : Chunk_Pointer;
Result : Natural := 0;
begin
Ptr := This.Unused;
while Ptr /= null loop
Result := Result + 1;
Ptr := Ptr.Next_Chunk;
end loop;
return Result;
end Unused_Chunks;
function Aligned
(Size : SSE.Storage_Count;
Alignment : SSE.Storage_Count) return SSE.Storage_Offset is
use type SSE.Storage_Count;
begin
return ((Size + Alignment - 1) / Alignment) * Alignment;
end Aligned;
end BC.Support.Managed_Storage;
syntax highlighted by Code2HTML, v. 0.9.1