|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 56294 (0xdbe6)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988, 1989. ALL RIGHTS RESERVED.
--
--
with Debug_Io;
with Semaphore;
with Exceptions;
with Heap_Management;
with Debug_Definitions;
with System;
with System_Definitions;
with Unchecked_Conversion;
-- SOME BACKGROUND.
--
-- Given the following Ada declarations:
-- type T (Variant : Natural) is
-- record
-- F1 : String (1 .. Variant);
-- F2 : ...
-- end record;
--
-- type Tp is access T;
--
-- P : Tp;
--
-- The compiler will access a variable which corresponds to the
-- collection for accessor Tp. During the elaboration of
-- type Tp, the following runtime call will be made:
--
-- local_var_tp := Allocate_Collection (Collection_Size, Extend_Collection);
--
-- If Collection_Size is 0, a default size will be used. If Extend_Collection
-- is False, then the initial collection will not be allowed to be extended.
-- A collection looks like:
--
-- local_var_tp -> Extendible (Boolean) \ \
-- Chunk_List (Collection_Link) | |
-- Units_Free (Integer) } Collection |
-- Free_List (Fragment_Link) | header |
-- Chunk_Size (Integer) | } a "chunk"
-- Lock (Semaphore) / | or a
-- <Collection_Size bytes> | collection
-- <4 bytes> /
--
-- Note that this structure differs from that used in other targets (more
-- on that later.) If a collection is allowed to be extendible, then
-- each extension results in a structure like above, and they are all
-- linked together via the Chunk_List field. A single allocation, like
-- variable P in the example, must be completely contained in a single
-- collection, or chunk - an allocation cannot span 2 or more chunks.
--
-- Other products use a simpler collection header. They do not include
-- a Units_Free field, which is presently used to speed up the allocation
-- of new objects in the collection, and they do not include a Lock field,
-- which is necessary when Ada tasks are implemented as real OS processes.
--
-- Within each chunk, there is a list (possibly empty) of free "fragments"
-- of memory. Each fragment is at least 8 bytes long and contains a
-- pointer to the next fragment in the list and a byte count of the
-- number of bytes which are free in the fragment (not including the 8 bytes
-- used to contain this fragment header). Since fragments must be at least
-- eight bytes long, the minimum size of an object which can be allocated
-- on the heap is 8 bytes. A request to allocate, say a 3 byte object,
-- would result in 8 bytes being allocated. This is so that if the 3 byte
-- object were to be deallocated later the object's allocation would be
-- large enough to contain a fragment descriptor so that the fragment could
-- be added to the list of free fragments. For each chunk, the list of
-- free fragments is rooted in the chunk's Free_List field. This is an
-- ordered list, sorted by increasing fragment address, so that the
-- coalesce algorithm can be small and have a linear time complexity.
-- For architectural efficiency reasons, each allocation is placed on an
-- 8 byte address boundary. Thus not only is an allocation made to be
-- at least 8 bytes long, it is also made to be a 8 byte multiple in
-- length. Thus a request to allocate a 13 byte object will actually
-- result in 16 bytes being allocated for the object.
--
-- OPTIMIZATION CANDIDATE:
-- The code below may operate slightly quicker if the "size of fragment"
-- field in the fragment header actually included the 8 bytes contained
-- in the fragment header. There is some amount of unnecessary adding
-- and subtracting of this constant 8 in the algorithms below.
--
-- If our sample program now contains the statement:
--
-- P := new T (13);
--
-- the following runtime call will be made:
--
-- P := Allocate_Fixed_Cell (13 + fixed_record_size, local_var_tp);
--
-- This implementation then searches each chunk in the chunk list rooted
-- in local_var_tp for a chunk whose Units_Free is greater than or equal
-- to the "13 + fixed_record_size" expression. If no such chunk is found,
-- the collection will be extended if allowed and possible. Once a possible
-- chunk is found, the free list is searched for a fragment large enough
-- to contain the allocation. If not is found, the search continues with
-- the next chunk in the list. Once a fragment is found, one of two
-- possibilities exist. If the fragment is 8 or more bytes bigger than
-- the requested allocation, then the fragment is split into two new fragments.
-- One of the new fragments is made just large enought to contain the
-- allocation and P will be made to point to it, and the other fragment will
-- be returned to the free list for the chunk. If the original fragment is
-- not 8 or more bytes larger than the requested allocation, the whole
-- fragment is used for the allocation - that is because there would not
-- be enough room in the origianl fragment to both grant the requested
-- allocation and to form a new fragment header so that the remaining bytes
-- could be returned to the free list.
--
-- For algorithmic efficiency reasons, when a fragment is split, the allocation
-- is given from the end of the fragment and the new fragment header which
-- describes the remaining unused bytes in the original fragment is kept
-- in the same location as the original fragment header. That way no
-- ajustments need be made in the linked list of fragments.
--
-- This implementation does allocations slightly differently than in some
-- of our other products. Each request is actually allocated 4 bytes
-- more than requested. The extra 4 bytes contains the length (not including
-- the 4 bytes used to hold the length) of the allocation. Note that this
-- is the adjusted allocation, not necessarily the original allocation.
-- This adjustment accounts for the 8 byte minimum and 8 byte multiple
-- requirements as described above. This length is used as an extra
-- sanity or security check if the object is disposed later. When an object
-- is to be disposed, both a pointer to the object and the unadjusted length
-- of the object is passed to the deallocator. The deallocator forms an
-- adjusted object length and checks that the length associated with the
-- actual allocated object matches this saved length. If P were to be
-- allocated simply 13 bytes, then P might contain, say, 16#7B27C# and
-- would look like:
--
-- 7B278: 00000010
-- P = 16#7b27C# -> 7B27C: xxxxxxxx
-- 7B780: xxxxxxxx
-- 7B784: xxxxxxxx
-- 7B788: xxxxxxxx
-- 7B78C: ........ (to make 8 byte multiple)
--
-- See that P points to a block of memory which can hold at least the requested
-- 13 bytes. It actually can hold 16 bytes, which is the next 8 byte multiple
-- value greater or equal to "min (13, 8)". As such, the 4 byte length value
-- stored at an address which is 4 bytes less than that pointed at by P
-- contains the value 16 (or 16#00000010#). If the program ever attempts to
-- deallocate P, the deallocator will apply the same adjustment algorithm to
-- the 13 value, yielding 16, and check that the 4 byte integer located 4
-- bytes lower than P contains 16. If not, something is seriously wrong
-- and a Storage_Error exception will be raised.
--
-- The last bit of background needed for understanding this package is to
-- know that when objects are disposed, the free list needs to be coalesced.
-- This involves merging adjacent free fragments into one larger free fragment.
-- If this is not done, it is likely that after some number of allocations
-- and deallocations that the next allocation request could fail, thinking
-- that there is no free fragment big enough to contain the requested
-- allocation, when in fact the whole heap might be free, consisting of
-- of large number of tiny fragments.
--
package body Storage_Management is
pragma Suppress (Access_Check);
pragma Suppress (Storage_Check);
use System_Definitions.Operators;
Byte : constant := System_Definitions.Byte_Size;
Byte_Length : constant := Byte * System_Definitions.Unit_Size;
Word : constant := System_Definitions.Word;
Word_Length : constant := System_Definitions.Word_Length;
Debug_Mode : Boolean renames Debug_Definitions.Debug_Storage_Management;
Safety_Check : Boolean renames Debug_Definitions.Safety_Check;
Chunk_Size_Divisor : constant := 8;
Default_Chunk_Size : constant := System_Definitions.Minimum_Block_Size;
--pragma Assert (Default_Chunk_Size mod Chunk_Size_Divisor = 0);
Boolean_Size : constant := System_Definitions.Boolean_Size;
Pointer_Size : constant := System_Definitions.Pointer_Size;
Integer_Size : constant := System_Definitions.Integer_Size;
type Fragment;
type Fragment_Link is access Fragment;
for Fragment_Link'Storage_Size use 0;
-- System_Definitions.Fake_Collection_Storage_Size;
type Fragment is
record
Next : Fragment_Link;
Size : Integer;
end record;
for Fragment use
record
Next at 0 * Word range 0 .. Word_Length - 1;
Size at 1 * Word range 0 .. Word_Length - 1;
end record;
--for Fragment'Size use 2 * Length_Word;
Fragment_Descriptor_Size : constant := Pointer_Size + Integer_Size;
-- pragma Assert (Fragment_Descriptor_Size mod Chunk_Size_Divisor = 0);
type Collection;
type Collection_Link is access Collection;
for Collection_Link'Storage_Size use
0; -- System_Definitions.Fake_Collection_Storage_Size;
type Collection is
record
Attributes : Collection_Attributes;
Free_List : Fragment_Link;
Chunk_Size : Integer;
Units_Free : Integer;
Chunk_List : Collection_Link;
Lock : Semaphore.Lock;
Extension_Size : Integer;
end record;
for Collection use
record at mod 4;
Attributes at 0 * Word range 0 .. Byte_Length - 1; -- 3 bytes filler
Chunk_List at 1 * Word range 0 .. Word_Length - 1;
Units_Free at 2 * Word range 0 .. Word_Length - 1;
Free_List at 3 * Word range 0 .. Word_Length - 1;
Chunk_Size at 4 * Word range 0 .. Word_Length - 1;
Lock at 5 * Word range 0 .. 2 * Word_Length - 1;
Extension_Size at 7 * Word range 0 .. Word_Length - 1;
end record;
--for Collection'Size use 8 * Word_Length;
Collection_Descriptor_Size : constant :=
5 * Integer_Size + 3 * Pointer_Size;
-- pragma Assert (Collection_Descriptor_Size mod Chunk_Size_Divisor = 0);
type Cell;
type Cell_Link is access Cell;
for Cell_Link'Storage_Size use
0; -- System_Definitions.Fake_Collection_Storage_Size;
type Cell is
record
Size : Integer;
end record;
for Cell use
record
Size at 0 * Word range 0 .. Word_Length - 1;
end record;
--for Cell'Size use 1 * Word_Length;
Cell_Descriptor_Size : constant := Integer_Size;
Free_Fragment_List : Fragment_Link;
pragma Import_Object (Free_Fragment_List, "__STORAGE_MGMT_FREELIST");
Storage_Lock : Semaphore.Lock;
pragma Import_Object (Storage_Lock, "__STORAGE_MGMT_SEMAPHORE");
function Address is new Unchecked_Conversion (Source => Fragment_Link,
Target => System_Address);
function Value is new Unchecked_Conversion (Source => System_Address,
Target => Fragment_Link);
function Address is new Unchecked_Conversion (Source => Collection_Link,
Target => System_Address);
function Value is new Unchecked_Conversion (Source => System_Address,
Target => Collection_Link);
function Address is new Unchecked_Conversion
(Source => Cell_Link, Target => System_Address);
function Value is new Unchecked_Conversion
(Source => System_Address, Target => Cell_Link);
-- package Debugging is
--
-- procedure Put_Fragment_List (Header : String; Start : Fragment_Link);
-- pragma Suppress (Elaboration_Check, Put_Fragment_List);
--
-- procedure Put_Collection_List
-- (Header : String; Start : Collection_Link);
-- pragma Suppress (Elaboration_Check, Put_Collection_List);
--
-- procedure Put_Cell_Info (Header : String;
-- Item : Cell_Link;
-- Clctn : Collection_Link);
-- pragma Suppress (Elaboration_Check, Put_Cell_Info);
--
-- procedure Put_Message (Msg : String);
-- pragma Suppress (Elaboration_Check, Put_Message);
--
-- end Debugging;
package Utilities is
function Align_Address (A : System_Address) return System_Address;
pragma Interface (Asm, Align_Address);
pragma Suppress (Elaboration_Check, Align_Address);
pragma Import_Function
(Align_Address, "__HEAP_ALIGN_VALUE", Mechanism => (Value));
function Align_Integer (I : Integer) return Integer;
pragma Interface (Asm, Align_Integer);
pragma Suppress (Elaboration_Check, Align_Integer);
pragma Import_Function
(Align_Integer, "__HEAP_ALIGN_VALUE", Mechanism => (Value));
end Utilities;
function Align (I : Integer) return Integer renames Utilities.Align_Integer;
function Align (A : System_Address) return System_Address
renames Utilities.Align_Address;
function "<" (L, R : Fragment_Link) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return System."<" (Address (L), Address (R));
end "<";
function Coalescible (Collection : Collection_Link) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return ((Collection.Attributes = Coalesce_And_No_Extend) or
(Collection.Attributes = Coalesce_And_Extend));
end Coalescible;
function Extendible (Attributes : Collection_Attributes) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return ((Attributes = Extend_And_No_Coalesce) or
(Attributes = Coalesce_And_Extend));
end Extendible;
function Extendible (Collection : Collection_Link) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Extendible (Attributes => Collection.Attributes);
end Extendible;
-- function Align (I : Integer) return Integer is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- Result : Integer := I;
-- begin
-- if I mod Chunk_Size_Divisor /= 0 then
-- Result := I + (Chunk_Size_Divisor - I mod Chunk_Size_Divisor);
-- end if;
-- if Debug_Mode then
-- Debugging.Put_Message (Integer'Image (I) & " aligns to " &
-- Integer'Image (Result));
-- end if;
-- return Result;
-- end Align;
--
-- function Align (A : System_Address) return System_Address is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- begin
-- return To_Address (Align (To_Integer (A)));
-- end Align;
--
-- procedure Assert_Aligned (A : System_Address) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- begin
-- if To_Integer (A) mod Chunk_Size_Divisor /= 0 then
-- Debugging.Put_Message ("*** Storage Management alignment error");
-- end if;
-- end Assert_Aligned;
\f
-- Allocate a segment of memory from the heap for use in creating
-- a collection.
--
-- This routine is NOT used to allocate user level objects, only
-- "chunks" of memory which contain a collection. The Units
-- parameter is assumed to have already been adjusted as necessary.
-- The allocation is merely added to the front of the free list of
-- fragments, rooted in Free_Fragment_List. The caller must remove
-- the segment from that list.
--
-- Exceptions:
-- o If unable to allocated "Units" bytes of memory, Storage_Error
-- will be raised.
--
-- Assertions:
-- o Free_Fragment_List points to a (possibly empty) free list of
-- fragments.
-- o Storage_Lock semaphore has been aquired before invoking this code.
--
-- Note: this routine is designed to be called by only Allocate_Collection
-- which has aquired Storage_Lock before calling here. This routine
-- must release Storage_Lock before raising any exceptions.
--
procedure New_Segment (Units : Integer) is
pragma Routine_Number (Runtime_Ids.Internal);
Allocated : System_Address;
New_Fragment : Fragment_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered New_Segment: units = " &
-- Integer'Image (Units));
-- end if;
Allocated := Heap_Management.Allocate (Units);
if To_Integer (Allocated) = 0 then
Semaphore.Release (Storage_Lock);
raise Storage_Error;
end if;
New_Fragment := Value (Allocated);
New_Fragment.Next := Free_Fragment_List;
New_Fragment.Size := Units - Fragment_Descriptor_Size;
Free_Fragment_List := New_Fragment;
end New_Segment;
-- Find the FIRST fragment in the free fragment list rooted in Free_List
-- which contains at least Size bytes.
--
-- Searches the fragment list for a first fit. If a large enough fragment
-- is found, one of two actions takes place:
-- o If the fragment is larger than Size bytes by at least the size
-- of a fragment descriptor, the fragment is split in two. One
-- fragment is made exactly Size bytes long and is returned. The
-- other fragment is the original fragment size minus Size bytes and
-- is left on the free fragment list. Note that the free portion is
-- left on the original free list so no pointers need to be adjusted.
-- This means that the allocated portion is taken from the end of
-- the original fragment.
-- o If the fragment is exactly large enough to contain Size, or if
-- it has fewer extra bytes than needed to contain a fragment
-- descriptor, then the whole fragment is removed from the free list
-- and returned as the allocation.
-- If no fragment on the list is large enough to contain Size bytes,
-- NULL is returned.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- The list of free fragments, rooted in Free_List is non circular and
-- terminates with NULL.
--
-- Note:
-- o The size field in a fragment header does not include the byte
-- count required to contain the fragment header itself. So, for
-- instance, if a fragment were exactly the size of a fragment
-- header (this is the minimum size of any possible entry in
-- the list), the size field for that element would be zero.
--
procedure Find_First_Spare (Size : Integer;
Free_List : in out Fragment_Link;
Item_Found : out Fragment_Link) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Spare : Fragment_Link := Free_List;
Prev_Spare : Fragment_Link := null;
Units_Remain : Integer;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Find_First_Spare: size = " &
-- Integer'Image (Size));
-- end if;
while Next_Spare /= null loop
Units_Remain := (Next_Spare.Size + Fragment_Descriptor_Size) - Size;
if Units_Remain >= 0 then
if Units_Remain < Fragment_Descriptor_Size then
if Prev_Spare /= null then
Prev_Spare.Next := Next_Spare.Next;
else
Free_List := Next_Spare.Next;
end if;
else
Next_Spare.Size := Units_Remain - Fragment_Descriptor_Size;
Next_Spare := Value (Plus_Ai (Address (Next_Spare),
Units_Remain));
end if;
Item_Found := Next_Spare;
return;
else
Prev_Spare := Next_Spare;
Next_Spare := Next_Spare.Next;
end if;
end loop;
Item_Found := null;
end Find_First_Spare;
function Allocate_Collection
(Units : Integer; Extend : Boolean) return System_Address is
-- just a skin for Create_Collection
pragma Routine_Number (Runtime_Ids.Allocate_Collection);
begin
if Extend then
return Create_Collection (Units, Coalesce_And_Extend, 0);
else
return Create_Collection (Units, Coalesce_And_No_Extend, 0);
end if;
end Allocate_Collection;
-- Allocate a NEW collection.
--
-- This routine is NOT used to extend an existing collection. A collection
-- large enough to contain a Units sized element is created. If Units is
-- zero, a default size is used. Note that in this implementation, an
-- allocated element also contains an extra 4 byte attribute which
-- indicates the size of the allocated element, thus Units is made at
-- least 4 bytes larger before the actual allocation is made (i.e.
-- Cell_Descriptor_Size). Also, as a collection is being made to contain
-- at least a Units sized object, bytes must also be reserved to contain
-- a collection header (i.e. Collection_Descriptor_Size bytes). Finally,
-- for architectural efficiency reasons, all objects on the heap are
-- allocated on 8 byte boundaries, so Units may be adjusted upward by
-- up to 7 bytes to insure that the next object allocated on the heap
-- will be at a 8 byte boundary. Although it is erroneous for the
-- compiler to call this routine with a negative Units value, this
-- condition is tested herein.
--
-- Access to the global heap as a whole (vs. heap within an allocated
-- collection) and the list of collections itself is guarded by the
-- Storage_Lock semaphore. This is necessary for this implementation
-- as Ada tasks are mapped to OS processes, so these runtime routines
-- must manage these resources in critical regions.
--
-- Upon completion, a collection containing a single free fragment is
-- returned.
--
-- Exceptions:
-- Storage_Error may be raised by the underlying routines if no
-- storage is available for the collection.
--
-- Assertions:
-- o New_Segment will cause an exception to be raised if it fails.
-- o No deadlock detection is tested in the contention between the
-- task management semaphore and the Storage_Lock semaphore.
-- o Find_First_Spare ensures that the returned fragment is no longer
-- on the free fragment list.
-- o Semaphore.Release raises no exceptions.
-- o New_Segment will release Storage_Lock semaphore if it fails.
--
-- Notes:
-- o The Units_Free and Chunk_Size fields of the collection header
-- do not include the byte count required to contain the collection
-- header itself.
--
function Create_Collection
(Units : Integer;
Attributes : Collection_Attributes := Coalesce_And_Extend;
Extension_Size : Integer := 0) return System_Address is
pragma Routine_Number (Runtime_Ids.Allocate_Collection);
Actual_Units : Integer;
New_Chunk : Fragment_Link;
New_Collection : Collection_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Allocate_Collection: units = " &
-- Integer'Image (Units));
-- end if;
if Units <= Use_Default_Chunk_Size then
--
-- Negative => Start with the default size
--
Actual_Units := Default_Chunk_Size;
elsif Units = Use_Descriptor_Or_Null_Size then
if Extendible (Attributes) then
--
-- Zero and extendible => Start with zero use
--
Actual_Units := Collection_Descriptor_Size +
Align (Cell_Descriptor_Size);
else
--
-- Zero and non extensible => no collection allocated
--
return System.Address_Zero;
end if;
else
--
-- Positive => Start with passed size
--
Actual_Units := Collection_Descriptor_Size +
Align (Units + Cell_Descriptor_Size);
end if;
Semaphore.Acquire (Storage_Lock);
Find_First_Spare (Actual_Units, Free_Fragment_List, New_Chunk);
if New_Chunk = null then
New_Segment (Actual_Units);
Find_First_Spare (Actual_Units, Free_Fragment_List, New_Chunk);
end if;
Semaphore.Release (Storage_Lock);
New_Collection := Value (Address (New_Chunk));
New_Chunk := Value (Plus_Ai (Address (New_Chunk),
Collection_Descriptor_Size));
New_Collection.Attributes := Attributes;
New_Collection.Chunk_List := null;
New_Collection.Units_Free := Actual_Units - Collection_Descriptor_Size;
New_Collection.Free_List := New_Chunk;
New_Collection.Chunk_Size := Actual_Units - Collection_Descriptor_Size;
New_Collection.Lock.Next := null;
New_Collection.Lock.Key := 0;
New_Chunk.Size := Actual_Units - Collection_Descriptor_Size -
Fragment_Descriptor_Size;
New_Chunk.Next := null;
if Extension_Size > 0 then
New_Collection.Extension_Size :=
Align (Extension_Size + Cell_Descriptor_Size);
else
New_Collection.Extension_Size := Default_Chunk_Size;
end if;
-- if Debug_Mode then
-- Debugging.Put_Message ("After Allocate_Collection -->");
-- Debugging.Put_Fragment_List (Header => "Spare pool",
-- Start => Free_Fragment_List);
-- Debugging.Put_Collection_List
-- (Header => "Collection list", Start => New_Collection);
-- end if;
return Address (New_Collection);
end Create_Collection;
-- Deallocate a collection.
--
-- Deallocate a collection and any extensions associated with it
-- by placing all storage used by the collection in the global list of
-- free fragments. For program security reasons, the collection
-- pointer is NULLed after it is deallocated. If a NULL pointer
-- is given to this routine, no action is performed and no error
-- is signalled - thus it is valid to attempt to deallocate a
-- collection more than once.
--
-- Access to the global heap as a whole (vs. heap within an allocated
-- collection) and the list of collections itself is guarded by the
-- Storage_Lock semaphore. This is necessary for this implementation
-- as Ada tasks are mapped to OS processes, so these runtime routines
-- must manage these resources in critical regions.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- o Addr points to a valid collection object. In particular,
-- it must no point to one of the extensions for a collection
-- but the collection object itself.
-- o No deadlock detection is tested in the contention between the
-- task management semaphore and the Storage_Lock semaphore.
-- o The list of free fragments, rooted in Free_List is non circular and
-- terminates with NULL.
--
-- Note:
-- If an exception is raised in the loop following aquisition of
-- the Storage_Lock semaphore, Storage_Lock is not released. This
-- could result in a deadlock condition later on.
--
-- Change History:
-- 891016 MDW Added code to coalesce the free fragment list. The
-- free fragment list is thus also now sorted in order
-- of increasing address.
--
procedure Deallocate_Collection (Addr : in out Address_Ref) is
pragma Routine_Number (Runtime_Ids.Deallocate_Collection);
Addr_Value : System_Address := Addr.all;
Collection_Base : Collection_Link;
Next_Collection : Collection_Link;
New_Fragment : Fragment_Link;
Prev_Fragment : Fragment_Link;
Search_Fragment : Fragment_Link;
Temp_Collection : Collection_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Deallocate_Collection");
-- end if;
if To_Integer (Addr_Value) = 0 then
-- if Debug_Mode then
-- Debugging.Put_Message ("Collection already null");
-- end if;
return;
end if;
Collection_Base := Value (Addr_Value);
Next_Collection := Collection_Base;
-- if Debug_Mode then
-- Debugging.Put_Collection_List
-- ("Deallocating Collection", Collection_Base);
-- end if;
Semaphore.Acquire (Storage_Lock);
loop
-- Iterate over a collection and its extensions.
Temp_Collection := Next_Collection.Chunk_List;
New_Fragment := Value (Address (Next_Collection));
Prev_Fragment := null;
Search_Fragment := Free_Fragment_List;
while (Search_Fragment /= null) and then
(Search_Fragment < New_Fragment) loop
-- Find the fragments which surround New_Fragment.
Prev_Fragment := Search_Fragment;
Search_Fragment := Search_Fragment.Next;
end loop;
New_Fragment.Next := Search_Fragment;
New_Fragment.Size := Next_Collection.Chunk_Size +
Collection_Descriptor_Size -
Fragment_Descriptor_Size;
if Prev_Fragment = null then
-- New_Fragment is new head of free fragment list.
Free_Fragment_List := New_Fragment;
else
-- Link New_Fragment into middle or end of free list.
Prev_Fragment.Next := New_Fragment;
if Value (Plus_Ai
(Address (Prev_Fragment),
Prev_Fragment.Size + Fragment_Descriptor_Size)) =
New_Fragment then
-- Coalesce Prev_Fragment with New_Fragment.
-- Note: Fragment_Descriptor_Size is already accounted
-- for in both fragments and so must be backed
-- out of one.
Prev_Fragment.Next := New_Fragment.Next;
Prev_Fragment.Size :=
Prev_Fragment.Size + New_Fragment.Size +
Fragment_Descriptor_Size;
New_Fragment := Prev_Fragment;
end if;
end if;
if (Search_Fragment /= null) and then
(Value (Plus_Ai (Address (New_Fragment),
New_Fragment.Size + Fragment_Descriptor_Size)) =
Search_Fragment) then
-- Coalesce New_Fragment with Search_Fragment.
-- Note that both New_Fragment and Search_Fragment have
-- accounted for Fragment_Descriptor_Size, so we must
-- discount it once when we coalesce.
New_Fragment.Next := Search_Fragment.Next;
New_Fragment.Size := New_Fragment.Size + Search_Fragment.Size +
Fragment_Descriptor_Size;
end if;
exit when Temp_Collection = null;
Next_Collection := Temp_Collection;
end loop;
Semaphore.Release (Storage_Lock);
-- if Debug_Mode then
-- Debugging.Put_Message ("After Deallocate_Collection -->");
-- Debugging.Put_Fragment_List (Header => "Spare pool",
-- Start => Free_Fragment_List);
-- end if;
Addr.all := To_Address (0);
end Deallocate_Collection;
-- Compute a size to extend a collection.
--
-- There is a non obvious optimization in this routine. The ">"
-- relational is used instead of ">=" so that when Allocate_Collection
-- is ultimately called it will do slightly less work.
--
-- Note: this code assumes that the call to create the collection
-- occurred in one of two ways. Either the original call
-- had a non zero Units (size) parameter, in which case the
-- collection is not extensible and this routine will not get
-- invoked, or the Units parameter is zero and the default
-- collection size is used for the first collection.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- none.
--
function Size_For_Extension
(Object_Size : Integer; Base_Clctn_Size : Integer)
return Integer is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Object_Size > Base_Clctn_Size then
return Object_Size;
else
return Base_Clctn_Size;
end if;
end Size_For_Extension;
-- Extend a collection.
--
-- Exceptions:
-- Storage_Error is raised if collection is not extensible. The
-- actual allocation may also raise Storage_Error.
--
-- Assertions:
--
function Extend_Collection (Units : Integer; Clctn : Collection_Link)
return Collection_Link is
pragma Routine_Number (Runtime_Ids.Internal);
Extension : Collection_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Extend_Collection");
-- end if;
if not Extendible (Clctn) then
raise Storage_Error;
end if;
Extension := Value (Create_Collection
(Size_For_Extension (Units,
Clctn.Extension_Size),
Clctn.Attributes, Clctn.Extension_Size));
Extension.Chunk_List := Clctn.Chunk_List;
Clctn.Chunk_List := Extension;
-- if Debug_Mode then
-- Debugging.Put_Message ("After Extend_Collection");
-- Debugging.Put_Fragment_List (Header => "Spare pool",
-- Start => Free_Fragment_List);
-- Debugging.Put_Collection_List
-- (Header => "Collection list", Start => Clctn);
-- end if;
return Extension;
end Extend_Collection;
-- Allocate a cell large enough to contain an object of Units bytes in
-- a collection.
--
-- A collection and all of its extensions are checked to find a fragment
-- large enough to contain a Units byte length object. If not found,
-- an attempt is made to extend the collection.
--
-- Exceptions:
-- Storage_Error is raised if the object cannot be allocated in a
-- collection and the collection is not extensible, or if the
-- collection is extensible but could not be extended to contain
-- an object of Units bytes.
--
-- Assertions:
-- o Extend_Collection will raise a Storage_Error exception if
-- it is unsuccessful.
--
-- Notes:
-- It is invalid for this routine to be called with a negative Units
-- value, but the condition is checked anyway. In this implementation,
-- each allocated object has an additional 4 byte attribute which
-- names the length of the allocation. This routine automatically
-- accounts for that additional attribute field. The result of this
-- routine is a pointer to this attribute field, it is the caller's
-- responsibility to ultimately return a pointer to the user's
-- program which points beyond this attribute field.
--
function Insert_Cell
(Units : Integer; Clctn : Collection_Link) return Cell_Link is
pragma Routine_Number (Runtime_Ids.Internal);
Actual_Size : Integer := Align (Units + Cell_Descriptor_Size);
Next_Clctn : Collection_Link := Clctn;
New_Chunk : Fragment_Link;
New_Cell : Cell_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Insert_Cell: units = " &
-- Integer'Image (Units));
-- end if;
if Units < 0 or Next_Clctn = null then
raise Exceptions.Runtime_Error;
end if;
for Retry_After_Extend_Collection in Boolean loop
while Next_Clctn /= null loop
if Next_Clctn.Units_Free >= Actual_Size then
Find_First_Spare (Actual_Size,
Next_Clctn.Free_List, New_Chunk);
if New_Chunk /= null then
Next_Clctn.Units_Free :=
Next_Clctn.Units_Free - Actual_Size;
New_Cell := Value (Address (New_Chunk));
New_Cell.Size := Actual_Size - Cell_Descriptor_Size;
-- if Debug_Mode then
-- Debugging.Put_Cell_Info
-- (Header => "After Insert_Cell ->",
-- Item => New_Cell,
-- Clctn => Clctn);
-- end if;
return New_Cell;
end if;
end if;
Next_Clctn := Next_Clctn.Chunk_List;
end loop;
-- if Debug_Mode then
-- Debugging.Put_Message ("Extending collection");
-- end if;
Next_Clctn := Extend_Collection (Actual_Size, Clctn);
-- if Debug_Mode then
-- Debugging.Put_Message ("Looping for retry in Insert_Cell");
-- end if;
end loop;
raise Exceptions.Runtime_Error;
return null;
end Insert_Cell;
-- Allocate an object in a collection.
--
-- The name of this routine is misleading as it is used to allocate all
-- types of objects in a collection. A pointer to a block of memory
-- large enough to contain a Units byte length object in the collection
-- is returned. Note that an additional 4 bytes (Cell_Descriptor_Size)
-- is allocated for the object to contain the cell length attribute
-- field (see discussions above).
--
-- Each collection contains its own semaphore which is used to guard
-- the update operation for free list manipulation and object allocation.
-- This is necessary in this implementation as Ada tasks are mapped to
-- OS processes.
--
-- Exceptions:
-- Storage_Error can be raised by the underlying routines.
--
-- Assertions:
-- o Collection points to a valid collection object.
--
-- Change History:
-- 891016 MDW Added code to release the In_Clctn.Lock semaphore in
-- the event that Storage_Error is raised.
--
function Allocate_Fixed_Cell (Units : Integer; Collection : System_Address)
return System_Address is
pragma Routine_Number (Runtime_Ids.Allocate_Fixed_Cell);
In_Clctn : Collection_Link;
New_Cell : Cell_Link;
Result : System_Address;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Allocate_Fixed_Cell");
-- end if;
In_Clctn := Value (Collection);
Semaphore.Acquire (In_Clctn.Lock);
begin
New_Cell := Insert_Cell (Units, In_Clctn);
Result := Plus_Ai (Address (New_Cell), Cell_Descriptor_Size);
Semaphore.Release (In_Clctn.Lock);
exception
when Storage_Error =>
Semaphore.Release (In_Clctn.Lock);
raise;
end;
return Result;
end Allocate_Fixed_Cell;
-- Determine if a cell is contained within a chunk.
--
-- This routine is used to determine which chunk (extension) of a
-- collection contains a cell which is to be disposed.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- o A_Chunk points to a valid collection object.
--
function Is_Contained_In (A_Chunk : Collection_Link; The_Cell : Cell_Link)
return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
Cell_Addr : System_Address := Address (The_Cell);
First_Byte : System_Address := Address (A_Chunk);
Last_Byte : System_Address :=
Plus_Ai (Plus_Ai (First_Byte, Collection_Descriptor_Size),
A_Chunk.Chunk_Size);
begin
return Lt (First_Byte, Cell_Addr) and then Le (Cell_Addr, Last_Byte);
end Is_Contained_In;
-- Deallocate an object in a collection.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- o Clctn points to a valid collection object.
--
-- Note:
-- It is invalid to provide a Cell parameter which does not represent
-- a valid object in the Clctn collection. This routine checks that
-- Cell has a valid attribute field (see discussion above) located at
-- 4 bytes before the cell pointer and that the cell is within the
-- set of collections owned by the access type.
--
-- Change History:
-- 891016 MDW Added code to colesce the free list for the collection.
-- Free list entries for the collection are now maintained
-- in sorted order by address.
--
procedure Remove_Cell
(Units : Integer; Clctn : Collection_Link; Cell : Cell_Link) is
pragma Routine_Number (Runtime_Ids.Internal);
Free_Chunk : Fragment_Link;
Freed_Size : Integer := Align (Units + Cell_Descriptor_Size);
Next_Clctn : Collection_Link := Clctn;
Prev_Fragment : Fragment_Link;
Search_Fragment : Fragment_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Remove_Cell");
-- end if;
if Safety_Check and then Cell.Size /=
(Freed_Size - Cell_Descriptor_Size) then
-- Debugging.Put_Message ("Cell.Size = " & Integer'Image (Cell.Size));
-- Debugging.Put_Message ("Units = " & Integer'Image (Units));
raise Exceptions.Runtime_Error;
end if;
while Next_Clctn /= null loop
if Is_Contained_In (Next_Clctn, Cell) then
if Coalescible (Next_Clctn) then
Next_Clctn.Units_Free := Next_Clctn.Units_Free + Freed_Size;
Free_Chunk := Value (Address (Cell));
Prev_Fragment := null;
Search_Fragment := Next_Clctn.Free_List;
while (Search_Fragment /= null) and then
(Search_Fragment < Free_Chunk) loop
-- Find fragments surrounding Free_Chunk.
Prev_Fragment := Search_Fragment;
Search_Fragment := Search_Fragment.Next;
end loop;
Free_Chunk.Size := Freed_Size - Fragment_Descriptor_Size;
Free_Chunk.Next := Search_Fragment;
if Prev_Fragment = null then
-- Free chunk is new head of free list.
Next_Clctn.Free_List := Free_Chunk;
else
-- Insert Free_Chunk into middle or end of free list.
Prev_Fragment.Next := Free_Chunk;
if Value (Plus_Ai (Address (Prev_Fragment),
Prev_Fragment.Size +
Fragment_Descriptor_Size)) =
Free_Chunk then
-- Coalesce Prev_Fragment and Free_Chunk.
-- Note that Fragment_Descriptor_Size was accounted
-- for in both fragments and so must be backed out
-- of one.
Prev_Fragment.Next := Free_Chunk.Next;
Prev_Fragment.Size :=
Prev_Fragment.Size + Free_Chunk.Size +
Fragment_Descriptor_Size;
Free_Chunk := Prev_Fragment;
end if;
end if;
if (Search_Fragment /= null) and then
(Value (Plus_Ai (Address (Free_Chunk),
Free_Chunk.Size +
Fragment_Descriptor_Size)) =
Search_Fragment) then
-- Coalesce Free_Chunk and Search_Fragment.
-- Note that Fragment_Descriptor_Size was accounted
-- for in both fragments and so must be backed out
-- of one.
Free_Chunk.Next := Search_Fragment.Next;
Free_Chunk.Size := Free_Chunk.Size +
Search_Fragment.Size +
Fragment_Descriptor_Size;
end if;
-- if Debug_Mode then
-- Debugging.Put_Message ("After Deallocate_Cell ->");
-- Debugging.Put_Collection_List
-- (Header => "Collection list", Start => Clctn);
-- end if;
return;
else -- not coalescible, stick at head of unordered free_list
Next_Clctn.Units_Free := Next_Clctn.Units_Free + Freed_Size;
Free_Chunk := Value (Address (Cell));
Free_Chunk.Size := Freed_Size - Fragment_Descriptor_Size;
Free_Chunk.Next := Next_Clctn.Free_List;
Next_Clctn.Free_List := Free_Chunk;
return;
end if;
else
Next_Clctn := Next_Clctn.Chunk_List;
end if;
end loop;
raise Exceptions.Runtime_Error;
end Remove_Cell;
-- Deallocate an object in a collection.
--
-- This routine name is misleading as it is used to deallocate any
-- type of object. After the cell is deallocated, the pointer is
-- set to NULL. If this routine is called with a NULL cell pointer,
-- no action takes place and no error is raised, thus it is valid
-- to repeatedly deallocate a cell. As described above, each collection
-- has a semaphore used to guard the free list and allocate/deallocate
-- process.
--
-- Exceptions:
-- none.
--
-- Assertions:
-- o Collection points to a valid collection.
-- o Cell points to a valid cell in the named collection.
-- o No exceptions are raised during deallocation (which could
-- cause the In_Clctn.Lock semaphore to remain aquired and
-- possibly cause a later deadlock).
--
procedure Deallocate_Fixed_Cell (Units : Integer;
Collection : System_Address;
Cell : Address_Ref) is
pragma Routine_Number (Runtime_Ids.Deallocate_Fixed_Cell);
Cell_Addr : System_Address := Cell.all;
In_Clctn : Collection_Link;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Deallocate_Fixed_Cell");
-- end if;
if Cell_Addr = To_Address (0) then
return;
end if;
In_Clctn := Value (Collection);
Semaphore.Acquire (In_Clctn.Lock);
Remove_Cell (Units => Units,
Clctn => In_Clctn,
Cell => Value (Minus_Ai
(Cell_Addr, Cell_Descriptor_Size)));
Semaphore.Release (In_Clctn.Lock);
Cell.all := To_Address (0);
end Deallocate_Fixed_Cell;
-- Return the size of heap allocated to contain the collection(s) for
-- an access type.
--
-- Note that each collection has a semaphore used to guard the collection
-- (see discussion above).
--
-- Exceptions:
-- none.
--
-- Assertions:
-- o Cp points to a valid collection.
-- o No exceptions are raised (which could cause the Base_Collection.Lock
-- semaphore to remain aquired which could later cause a deadlock).
--
-- Note:
-- NEED TO CHECK THE PROPER USE OF SEMAPHORES IN THIS ROUTINE.
--
function Collection_Size (Cp : System_Address) return Integer is
pragma Routine_Number (Runtime_Ids.Collection_Size);
Base_Collection : Collection_Link;
Next_Collection : Collection_Link;
Total_Size : Integer;
begin
Base_Collection := Value (Cp);
Semaphore.Acquire (Base_Collection.Lock);
Total_Size := Base_Collection.Chunk_Size;
if Extendible (Base_Collection) then
Next_Collection := Base_Collection;
loop
Next_Collection := Next_Collection.Chunk_List;
exit when Next_Collection = null;
Total_Size := Total_Size + Next_Collection.Chunk_Size;
end loop;
end if;
Semaphore.Release (Base_Collection.Lock);
return Total_Size;
end Collection_Size;
-- package body Debugging is
--
-- pragma Suppress (Storage_Check);
--
-- procedure Put_Message (Msg : String) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- begin
-- Debug_Io.New_Line;
-- Debug_Io.Put_Line (Msg);
-- end Put_Message;
--
-- procedure Put_Fragment_List (Header : String; Start : Fragment_Link) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- Next : Fragment_Link := Start;
-- begin
-- if Header /= "" then
-- Debug_Io.Put_Line (Header);
-- end if;
--
-- while Next /= null loop
-- Debug_Io.Put_Line (" Address Size Next");
-- Debug_Io.Put
-- (To_Integer (Address (Next)), Width => 8, In_Hex => True);
-- Debug_Io.Put (": ");
-- Debug_Io.Put (Next.Size);
-- if Next.Next /= null then
-- Debug_Io.Put (" ");
-- Debug_Io.Put (To_Integer (Address (Next.Next)),
-- Width => 8,
-- In_Hex => True);
-- else
-- Debug_Io.Put (" null");
-- end if;
-- Debug_Io.New_Line;
-- Next := Next.Next;
-- end loop;
-- Debug_Io.New_Line;
-- end Put_Fragment_List;
--
-- procedure Put_Collection_List
-- (Header : String; Start : Collection_Link) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- Next : Collection_Link := Start;
-- begin
-- if Header /= "" then
-- Debug_Io.Put_Line (Header);
-- end if;
--
-- while Next /= null loop
-- Debug_Io.Put_Line
-- (" Address SizeAC NextAC NxtFre SizFre Ext");
-- Debug_Io.Put
-- (To_Integer (Address (Next)), Width => 8, In_Hex => True);
-- Debug_Io.Put (": ");
-- Debug_Io.Put (Next.Chunk_Size);
-- Debug_Io.Put (" ");
-- if Next.Chunk_List /= null then
-- Debug_Io.Put (To_Integer (Address (Next.Chunk_List)),
-- Width => 8,
-- In_Hex => True);
-- else
-- Debug_Io.Put (" null ");
-- end if;
-- Debug_Io.Put (" ");
-- Debug_Io.Put (To_Integer (Address (Next.Free_List)),
-- Width => 8,
-- In_Hex => True);
-- Debug_Io.Put (Next.Units_Free);
-- Debug_Io.Put (" ");
-- if Next.Extendible then
-- Debug_Io.Put ('T');
-- else
-- Debug_Io.Put ('F');
-- end if;
--
-- Debug_Io.New_Line;
--
-- Put_Fragment_List (Header => "", Start => Next.Free_List);
--
-- Debug_Io.New_Line;
-- Debug_Io.New_Line;
-- Next := Next.Chunk_List;
-- end loop;
-- Debug_Io.New_Line;
-- end Put_Collection_List;
--
-- procedure Put_Cell_Info (Header : String;
-- Item : Cell_Link;
-- Clctn : Collection_Link) is
-- pragma Routine_Number (Runtime_Ids.Internal);
-- begin
-- if Header /= "" then
-- Debug_Io.Put_Line (Header);
-- end if;
--
-- Debug_Io.Put ("Allocated cell of size ");
-- Debug_Io.Put (Item.Size);
--
-- Debug_Io.Put (" at address ");
-- Debug_Io.Put
-- (To_Integer (Address (Item)), Width => 8, In_Hex => True);
-- Debug_Io.New_Line;
-- end Put_Cell_Info;
--
-- end Debugging;
begin
Free_Fragment_List := null;
Storage_Lock := (null, 0);
end Storage_Management;
pragma Export_Elaboration_Procedure ("__STORAGE_MGMT_BODY_ELAB");
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);