File : bc-support-managed_storage.adb
-- Copyright (C) 1994-1999 Grady Booch, Pat Rogers and Simon Wright.
-- All Rights Reserved.
--
-- This program is free software; you can redistribute it
-- and/or modify it under the terms of the Ada Community
-- License which comes with this Library.
--
-- This program 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 Ada Community License for more details.
-- You should have received a copy of the Ada Community
-- License with this library, in the file named "Ada Community
-- License" or "ACL". If not, contact the author of this library
-- for a copy.
--
-- $Id: bc-support-managed_storage.adb,v 1.7 1999/04/10 14:38:21 simon Exp $
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 : in System.Address; At_Location : in 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 : in System.Address; At_Location : in 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 : in SSE.Storage_Count;
Requested_Alignment : in 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 : in SSE.Storage_Count;
Alignment : in 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; -- note chunks are reused when possible so this is necessary
Ptr.Next_Chunk := null; -- ditto
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 : in System.Address;
Size_In_Storage_Elements : in SSE.Storage_Count;
Alignment : in 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 and 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
begin
return SSE.Storage_Count'Last; -- well, what else can we say!?
end Storage_Size;
procedure Preallocate_Chunks( This : in out Pool; Count : in 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
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;
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;