===================================================================
@@ -1,568 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Unchecked_Conversion;
-
-with System; use System;
-with System.Address_Image;
-with System.IO; use System.IO;
-with System.Soft_Links; use System.Soft_Links;
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Storage_Pools; use System.Storage_Pools;
-
-package body Ada.Finalization.Heap_Management is
-
- Debug : constant Boolean := False;
- -- True for debugging printouts.
-
- Header_Size : constant Storage_Count := Node'Size / Storage_Unit;
- -- Size of the header in bytes. Added to Storage_Size requested by
- -- Allocate/Deallocate to determine the Storage_Size passed to the
- -- underlying pool.
-
- function Address_To_Node_Ptr is
- new Ada.Unchecked_Conversion (Address, Node_Ptr);
-
- procedure Attach (N : Node_Ptr; L : Node_Ptr);
- -- Prepend a node to a list
-
- procedure Detach (N : Node_Ptr);
- -- Unhook a node from an arbitrary list
-
- procedure Fin_Assert (Condition : Boolean; Message : String);
- -- Asserts that the condition is True. Used instead of pragma Assert in
- -- delicate places where raising an exception would cause re-invocation of
- -- finalization. Instead of raising an exception, aborts the whole process.
-
- function Is_Empty (Objects : Node_Ptr) return Boolean;
- -- True if the Objects list is empty
-
- ----------------
- -- Fin_Assert --
- ----------------
-
- procedure Fin_Assert (Condition : Boolean; Message : String) is
-
- procedure Fail;
- -- Use a separate procedure to make it easy to set a breakpoint here.
-
- ----------
- -- Fail --
- ----------
-
- procedure Fail is
- begin
- Put_Line ("Heap_Management: Fin_Assert failed: " & Message);
- -- ???OS_Lib.OS_Abort;
- -- Breaks ravenscar runtimes
- end Fail;
-
- -- Start of processing for Fin_Assert
-
- begin
- if not Condition then
- Fail;
- end if;
- end Fin_Assert;
-
- ---------------------------
- -- Add_Offset_To_Address --
- ---------------------------
-
- function Add_Offset_To_Address
- (Addr : System.Address;
- Offset : System.Storage_Elements.Storage_Offset) return System.Address
- is
- begin
- return System.Storage_Elements."+" (Addr, Offset);
- end Add_Offset_To_Address;
-
- --------------
- -- Allocate --
- --------------
-
- procedure Allocate
- (Collection : in out Finalization_Collection;
- Addr : out System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Needs_Header : Boolean := True)
- is
- begin
- -- Allocation of an object with controlled parts
-
- if Needs_Header then
-
- -- Do not allow the allocation of controlled objects while the
- -- associated collection is being finalized.
-
- if Collection.Finalization_Started then
- raise Program_Error with "allocation after finalization started";
- end if;
-
- declare
- Header_Offset : Storage_Offset;
- N_Addr : Address;
- N_Ptr : Node_Ptr;
-
- begin
- -- Offset from the header to the actual object. The header is
- -- just in front of the object. There may be padding space before
- -- the header.
-
- if Alignment > Header_Size then
- Header_Offset := Alignment;
- else
- Header_Offset := Header_Size;
- end if;
-
- -- Use the underlying pool to allocate enough space for the object
- -- and the list header. The returned address points to the list
- -- header. If locking is necessary, it will be done by the
- -- underlying pool.
-
- Allocate
- (Collection.Base_Pool.all,
- N_Addr,
- Storage_Size + Header_Offset,
- Alignment);
-
- -- Map the allocated memory into a Node record. This converts the
- -- top of the allocated bits into a list header.
-
- N_Ptr := Address_To_Node_Ptr
- (N_Addr + Header_Offset - Header_Size);
- Attach (N_Ptr, Collection.Objects'Unchecked_Access);
-
- -- Move the address from Prev to the start of the object. This
- -- operation effectively hides the list header.
-
- Addr := N_Addr + Header_Offset;
- end;
-
- -- Allocation of a non-controlled object
-
- else
- Allocate
- (Collection.Base_Pool.all,
- Addr,
- Storage_Size,
- Alignment);
- end if;
-
- pragma Assert (Addr mod Alignment = 0);
- end Allocate;
-
- ------------
- -- Attach --
- ------------
-
- procedure Attach (N : Node_Ptr; L : Node_Ptr) is
- begin
- Lock_Task.all;
-
- L.Next.Prev := N;
- N.Next := L.Next;
- L.Next := N;
- N.Prev := L;
-
- Unlock_Task.all;
-
- -- Note: no need to unlock in case of exceptions; the above code cannot
- -- raise any.
-
- end Attach;
-
- ---------------
- -- Base_Pool --
- ---------------
-
- function Base_Pool
- (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr
- is
- begin
- return Collection.Base_Pool;
- end Base_Pool;
-
- ----------------
- -- Deallocate --
- ----------------
-
- procedure Deallocate
- (Collection : in out Finalization_Collection;
- Addr : System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Has_Header : Boolean := True)
- is
- pragma Assert (Addr mod Alignment = 0);
- begin
- -- Deallocation of an object with controlled parts
-
- if Has_Header then
- declare
- Header_Offset : Storage_Offset;
- N_Addr : Address;
- N_Ptr : Node_Ptr;
-
- begin
- -- Offset from the header to the actual object.
-
- if Alignment > Header_Size then
- Header_Offset := Alignment;
- else
- Header_Offset := Header_Size;
- end if;
-
- -- Converts from the object to the list header
-
- N_Ptr := Address_To_Node_Ptr (Addr - Header_Size);
- Detach (N_Ptr);
-
- -- Converts the bits preceding the object the block address.
-
- N_Addr := Addr - Header_Offset;
-
- -- Use the underlying pool to destroy the object along with the
- -- list header.
-
- Deallocate
- (Collection.Base_Pool.all,
- N_Addr,
- Storage_Size + Header_Size,
- Alignment);
- end;
-
- -- Deallocation of a non-controlled object
-
- else
- Deallocate
- (Collection.Base_Pool.all,
- Addr,
- Storage_Size,
- Alignment);
- end if;
- end Deallocate;
-
- ------------
- -- Detach --
- ------------
-
- procedure Detach (N : Node_Ptr) is
- begin
- pragma Debug (Fin_Assert (N /= null, "Detach null"));
-
- Lock_Task.all;
-
- if N.Next = null then
- pragma Assert (N.Prev = null);
-
- else
- N.Prev.Next := N.Next;
- N.Next.Prev := N.Prev;
- N.Next := null;
- N.Prev := null;
- end if;
-
- Unlock_Task.all;
-
- -- Note: no need to unlock in case of exceptions; the above code cannot
- -- raise any.
-
- end Detach;
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize
- (Collection : in out Finalization_Collection)
- is
- Ex_Occur : Exception_Occurrence;
- Raised : Boolean := False;
-
- begin
- if Debug then
- Put_Line ("-->Heap_Management: ");
- pcol (Collection);
- end if;
-
- -- Set Finalization_Started to prevent any allocations of objects with
- -- controlled parts during finalization. The associated access type is
- -- about to go out of scope; Finalization_Started is never again
- -- modified.
-
- if Collection.Finalization_Started then
-
- -- ???Needed for shared libraries
-
- return;
- end if;
-
- pragma Debug (Fin_Assert (not Collection.Finalization_Started,
- "Finalize: already started"));
- Collection.Finalization_Started := True;
-
- -- For each object in the Objects list, detach it, and finalize it. Note
- -- that other tasks can be doing Unchecked_Deallocations at the same
- -- time, so we need to beware of race conditions.
-
- while not Is_Empty (Collection.Objects'Unchecked_Access) loop
-
- declare
- Node : constant Node_Ptr := Collection.Objects.Next;
- begin
- -- Remove the current node from the list first, in case some other
- -- task is simultaneously doing Unchecked_Deallocation on this
- -- object. Detach does Lock_Task. Note that we can't Lock_Task
- -- during Finalize_Address, because finalization can do pretty
- -- much anything.
-
- Detach (Node);
-
- -- ??? Kludge: Don't do anything until the proper place to set
- -- primitive Finalize_Address has been determined.
-
- if Collection.Finalize_Address /= null then
- declare
- Object_Address : constant Address :=
- Node.all'Address + Header_Size;
- -- Get address of object from address of header
-
- begin
- Collection.Finalize_Address (Object_Address);
- exception
- when Fin_Except : others =>
- if not Raised then
- Raised := True;
- Save_Occurrence (Ex_Occur, Fin_Except);
- end if;
- end;
- end if;
- end;
- end loop;
-
- if Debug then
- Put_Line ("<--Heap_Management: ");
- pcol (Collection);
- end if;
-
- -- If the finalization of a particular node raised an exception, reraise
- -- it after the remainder of the list has been finalized.
-
- if Raised then
- if Debug then
- Put_Line ("Heap_Management: reraised");
- end if;
-
- Reraise_Occurrence (Ex_Occur);
- end if;
- end Finalize;
-
- ----------------
- -- Initialize --
- ----------------
-
- overriding procedure Initialize
- (Collection : in out Finalization_Collection)
- is
- begin
- -- The dummy head must point to itself in both directions
-
- Collection.Objects.Next := Collection.Objects'Unchecked_Access;
- Collection.Objects.Prev := Collection.Objects'Unchecked_Access;
- pragma Assert (Is_Empty (Collection.Objects'Unchecked_Access));
- end Initialize;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Objects : Node_Ptr) return Boolean is
- begin
- pragma Debug
- (Fin_Assert ((Objects.Next = Objects) = (Objects.Prev = Objects),
- "Is_Empty"));
- return Objects.Next = Objects;
- end Is_Empty;
-
- ----------
- -- pcol --
- ----------
-
- procedure pcol (Collection : Finalization_Collection) is
- Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
- -- "Unrestricted", because we are getting access-to-variable of a
- -- constant! Normally worrisome, this is OK for debugging code.
-
- Head_Seen : Boolean := False;
- N_Ptr : Node_Ptr;
-
- begin
- -- Output the basic contents of the collection
-
- -- Collection: 0x123456789
- -- Base_Pool : null <or> 0x123456789
- -- Fin_Addr : null <or> 0x123456789
- -- Fin_Start : TRUE <or> FALSE
-
- Put ("Collection: ");
- Put_Line (Address_Image (Collection'Address));
-
- Put ("Base_Pool : ");
-
- if Collection.Base_Pool = null then
- Put_Line (" null");
- else
- Put_Line (Address_Image (Collection.Base_Pool'Address));
- end if;
-
- Put ("Fin_Addr : ");
-
- if Collection.Finalize_Address = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (Collection.Finalize_Address'Address));
- end if;
-
- Put ("Fin_Start : ");
- Put_Line (Collection.Finalization_Started'Img);
-
- -- Output all chained elements. The format is the following:
-
- -- ^ <or> ? <or> null
- -- |Header: 0x123456789 (dummy head)
- -- | Prev: 0x123456789
- -- | Next: 0x123456789
- -- V
-
- -- ^ - the current element points back to the correct element
- -- ? - the current element points back to an erroneous element
- -- n - the current element points back to null
-
- -- Header - the address of the list header
- -- Prev - the address of the list header which the current element
- -- - points back to
- -- Next - the address of the list header which the current element
- -- - points to
- -- (dummy head) - present if dummy head
-
- N_Ptr := Head;
- while N_Ptr /= null loop -- Should never be null; we being defensive
- Put_Line ("V");
-
- -- We see the head initially; we want to exit when we see the head a
- -- SECOND time.
-
- if N_Ptr = Head then
- exit when Head_Seen;
-
- Head_Seen := True;
- end if;
-
- -- The current element is null. This should never happen since the
- -- list is circular.
-
- if N_Ptr.Prev = null then
- Put_Line ("null (ERROR)");
-
- -- The current element points back to the correct element
-
- elsif N_Ptr.Prev.Next = N_Ptr then
- Put_Line ("^");
-
- -- The current element points to an erroneous element
-
- else
- Put_Line ("? (ERROR)");
- end if;
-
- -- Output the header and fields
-
- Put ("|Header: ");
- Put (Address_Image (N_Ptr.all'Address));
-
- -- Detect the dummy head
-
- if N_Ptr = Head then
- Put_Line (" (dummy head)");
- else
- Put_Line ("");
- end if;
-
- Put ("| Prev: ");
-
- if N_Ptr.Prev = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (N_Ptr.Prev.all'Address));
- end if;
-
- Put ("| Next: ");
-
- if N_Ptr.Next = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (N_Ptr.Next.all'Address));
- end if;
-
- N_Ptr := N_Ptr.Next;
- end loop;
- end pcol;
-
- ------------------------------
- -- Set_Finalize_Address_Ptr --
- ------------------------------
-
- procedure Set_Finalize_Address_Ptr
- (Collection : in out Finalization_Collection;
- Proc_Ptr : Finalize_Address_Ptr)
- is
- begin
- Collection.Finalize_Address := Proc_Ptr;
- end Set_Finalize_Address_Ptr;
-
- --------------------------
- -- Set_Storage_Pool_Ptr --
- --------------------------
-
- procedure Set_Storage_Pool_Ptr
- (Collection : in out Finalization_Collection;
- Pool_Ptr : Any_Storage_Pool_Ptr)
- is
- begin
- Collection.Base_Pool := Pool_Ptr;
- end Set_Storage_Pool_Ptr;
-
-end Ada.Finalization.Heap_Management;
===================================================================
@@ -1,161 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-with System;
-with System.Storage_Elements;
-with System.Storage_Pools;
-
-package Ada.Finalization.Heap_Management is
-
- -- A reference to any derivation of Root_Storage_Pool. Since this type may
- -- not be used to allocate objects, its storage size is zero.
-
- type Any_Storage_Pool_Ptr is
- access System.Storage_Pools.Root_Storage_Pool'Class;
- for Any_Storage_Pool_Ptr'Storage_Size use 0;
-
- -- ??? Comment needed on overall mechanism
-
- type Finalization_Collection is
- new Ada.Finalization.Limited_Controlled with private;
-
- type Finalization_Collection_Ptr is access all Finalization_Collection;
- for Finalization_Collection_Ptr'Storage_Size use 0;
-
- -- A reference used to describe primitive Finalize_Address
-
- type Finalize_Address_Ptr is access procedure (Obj : System.Address);
-
- -- Since RTSfind cannot contain names of the form RE_"+", the following
- -- routine serves as a wrapper around System.Storage_Elements."+".
-
- function Add_Offset_To_Address
- (Addr : System.Address;
- Offset : System.Storage_Elements.Storage_Offset) return System.Address;
-
- procedure Allocate
- (Collection : in out Finalization_Collection;
- Addr : out System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Needs_Header : Boolean := True);
- -- Allocate a chunk of memory described by Storage_Size and Alignment on
- -- Collection's underlying storage pool. Return the address of the chunk.
- -- The routine creates a list header which precedes the chunk of memory if
- -- Needs_Header is True. If allocated, the header is attached to the
- -- Collection's objects. The interface to this routine is provided by
- -- Build_Allocate_Deallocate_Proc.
-
- function Base_Pool
- (Collection : Finalization_Collection) return Any_Storage_Pool_Ptr;
- -- Return a reference to the underlying storage pool of Collection
-
- procedure Deallocate
- (Collection : in out Finalization_Collection;
- Addr : System.Address;
- Storage_Size : System.Storage_Elements.Storage_Count;
- Alignment : System.Storage_Elements.Storage_Count;
- Has_Header : Boolean := True);
- -- Deallocate a chunk of memory described by Storage_Size and Alignment
- -- from Collection's underlying storage pool. The beginning of the memory
- -- chunk is designated by Addr. The routine detaches and destroys the
- -- preceding list header if flag Has_Header is set. The interface to this
- -- routine is provided by Build_Allocate_Deallocate_Proc.
-
- overriding procedure Finalize
- (Collection : in out Finalization_Collection);
- -- Traverse objects of Collection, invoking Finalize_Address on each one
-
- overriding procedure Initialize
- (Collection : in out Finalization_Collection);
- -- Initialize the finalization list to empty
-
- procedure Set_Finalize_Address_Ptr
- (Collection : in out Finalization_Collection;
- Proc_Ptr : Finalize_Address_Ptr);
- -- Set the finalization address routine of a finalization collection
-
- procedure Set_Storage_Pool_Ptr
- (Collection : in out Finalization_Collection;
- Pool_Ptr : Any_Storage_Pool_Ptr);
- -- Set the underlying storage pool of a finalization collection
-
-private
- -- Homogeneous collection types
-
- type Node;
- type Node_Ptr is access all Node;
- pragma No_Strict_Aliasing (Node_Ptr);
-
- -- The following record type should really be limited, but we can see the
- -- full view of Limited_Controlled, which is NOT limited. Note that default
- -- initialization does not happen for this type (the pointers will not be
- -- automatically set to null), because of the games we're playing with
- -- address arithmetic. Code in the body assumes that the size of
- -- this record is a power of 2 to deal with alignment.
-
- type Node is record
- Prev : Node_Ptr;
- Next : Node_Ptr;
- end record;
-
- type Finalization_Collection is
- new Ada.Finalization.Limited_Controlled with
- record
- Base_Pool : Any_Storage_Pool_Ptr;
- -- All objects and node headers are allocated on this underlying pool;
- -- the collection is simply a wrapper around it.
-
- Objects : aliased Node;
- -- The head of a doubly linked list containing all allocated objects
- -- with controlled parts that still exist (Unchecked_Deallocation has
- -- not been done on them).
-
- Finalize_Address : Finalize_Address_Ptr;
- -- A reference to a routine that finalizes an object denoted by its
- -- address. The collection must be homogeneous since the same routine
- -- will be invoked for every allocated object when the pool is
- -- finalized.
-
- Finalization_Started : Boolean := False;
- pragma Atomic (Finalization_Started);
- -- When the finalization of a collection takes place, any allocations of
- -- objects with controlled or protected parts on the same collection are
- -- prohibited and the action must raise Program_Error. This needs to be
- -- atomic, because it is accessed without Lock_Task/Unlock_Task. See
- -- RM-4.8(10.2/2).
- end record;
-
- procedure pcol (Collection : Finalization_Collection);
- -- Output the contents of a collection in a readable form. Intended for
- -- debugging purposes.
-
-end Ada.Finalization.Heap_Management;
===================================================================
@@ -1353,7 +1353,7 @@
Set_Has_Task (T, False);
Set_Has_Controlled_Component (T, False);
- -- Initialize Associated_Collection explicitly to Empty, to avoid
+ -- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
-- established by a limited with and an overlaid version of this field
-- (Stored_Constraint) was initialized for the incomplete view.
@@ -1361,10 +1361,10 @@
-- This reset is performed in most cases except where the access type
-- has been created for the purposes of allocating or deallocating a
-- build-in-place object. Such access types have explicitly set pools
- -- and collections.
+ -- and finalization masters.
if No (Associated_Storage_Pool (T)) then
- Set_Associated_Collection (T, Empty);
+ Set_Finalization_Master (T, Empty);
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding and access-constant
===================================================================
@@ -111,6 +111,7 @@
"a-titest", -- Ada.Text_IO.Text_Streams
"a-unccon", -- Ada.Unchecked_Conversion
"a-uncdea", -- Ada.Unchecked_Deallocation
+ "a-undesu", -- Ada.Unchecked_Deallocate_Subpool
"a-witeio", -- Ada.Wide_Text_IO
"a-wtcoio", -- Ada.Wide_Text_IO.Complex_IO
"a-wtedit", -- Ada.Wide_Text_IO.Editing
@@ -339,6 +340,7 @@
"s-rpc ", -- System.Rpc
"s-stoele", -- System.Storage_Elements
"s-stopoo", -- System.Storage_Pools
+ "s-stposu", -- System.Storage_Pools.Subpools
--------------------------------------
-- GNAT Defined Additions to System --
===================================================================
@@ -431,8 +431,8 @@
-- whether the inner logic should be dictated by state counters.
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
- -- Subsidiary to Make_Finalize_Address_Body and Make_Deep_Array_Body.
- -- Generate the following statements:
+ -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
+ -- Make_Deep_Record_Body. Generate the following statements:
--
-- declare
-- type Acc_Typ is access all Typ;
@@ -797,11 +797,11 @@
Parameter_Associations => Actuals)))));
end Build_Exception_Handler;
- -----------------------------------
- -- Build_Finalization_Collection --
- -----------------------------------
+ -------------------------------
+ -- Build_Finalization_Master --
+ -------------------------------
- procedure Build_Finalization_Collection
+ procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Encl_Scope : Entity_Id := Empty)
@@ -837,7 +837,7 @@
return False;
end In_Deallocation_Instance;
- -- Start of processing for Build_Finalization_Collection
+ -- Start of processing for Build_Finalization_Master
begin
-- Certain run-time configurations and targets do not provide support
@@ -847,16 +847,13 @@
return;
-- Various machinery such as freezing may have already created a
- -- collection.
+ -- finalization master.
- elsif Present (Associated_Collection (Typ)) then
+ elsif Present (Finalization_Master (Typ)) then
return;
-- Do not process types that return on the secondary stack
- -- ??? The need for a secondary stack should be revisited and perhaps
- -- changed.
-
elsif Present (Associated_Storage_Pool (Typ))
and then Is_RTE (Associated_Storage_Pool (Typ), RE_SS_Pool)
then
@@ -875,7 +872,7 @@
return;
-- Ignore the general use of anonymous access types unless the context
- -- requires a collection.
+ -- requires a finalization master.
elsif Ekind (Typ) = E_Anonymous_Access_Type
and then No (Ins_Node)
@@ -883,7 +880,7 @@
return;
-- Do not process non-library access types when restriction No_Nested_
- -- Finalization is in effect since collections are controlled objects.
+ -- Finalization is in effect since masters are controlled objects.
elsif Restriction_Active (No_Nested_Finalization)
and then not Is_Library_Level_Entity (Typ)
@@ -901,87 +898,85 @@
end if;
declare
- Loc : constant Source_Ptr := Sloc (Typ);
- Actions : constant List_Id := New_List;
- Coll_Id : Entity_Id;
- Pool_Id : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Actions : constant List_Id := New_List;
+ Fin_Mas_Id : Entity_Id;
+ Pool_Id : Entity_Id;
+ Ptr_Typ : Entity_Id := Typ;
begin
+ -- Access subtypes must use the storage pool of their base type
+
+ if Ekind (Ptr_Typ) = E_Access_Subtype then
+ Ptr_Typ := Base_Type (Ptr_Typ);
+ end if;
+
-- Generate:
- -- Fnn : Finalization_Collection;
+ -- Fnn : aliased Finalization_Master;
- -- Source access types use fixed names for their collections since
- -- the collection is inserted only once in the same source unit and
- -- there is no possible name overlap. Internally-generated access
- -- types on the other hand use temporaries as collection names due
- -- to possible name collisions.
+ -- Source access types use fixed master names since the master is
+ -- inserted in the same source unit only once. The only exception to
+ -- this are instances using the same access type as generic actual.
- if Comes_From_Source (Typ) then
- Coll_Id :=
+ if Comes_From_Source (Ptr_Typ)
+ and then not Inside_A_Generic
+ then
+ Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "FC"));
+ Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
+
+ -- Internally generated access types use temporaries as their names
+ -- due to possible collision with identical names coming from other
+ -- packages.
+
else
- Coll_Id := Make_Temporary (Loc, 'F');
+ Fin_Mas_Id := Make_Temporary (Loc, 'F');
end if;
Append_To (Actions,
Make_Object_Declaration (Loc,
- Defining_Identifier => Coll_Id,
+ Defining_Identifier => Fin_Mas_Id,
+ Aliased_Present => True,
Object_Definition =>
- New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
+ New_Reference_To (RTE (RE_Finalization_Master), Loc)));
-- Storage pool selection and attribute decoration of the generated
- -- collection. Since .NET/JVM compilers do not support pools, this
- -- step is skipped.
+ -- master. Since .NET/JVM compilers do not support pools, this step
+ -- is skipped.
if VM_Target = No_VM then
-- If the access type has a user-defined pool, use it as the base
-- storage medium for the finalization pool.
- if Present (Associated_Storage_Pool (Typ)) then
- Pool_Id := Associated_Storage_Pool (Typ);
+ if Present (Associated_Storage_Pool (Ptr_Typ)) then
+ Pool_Id := Associated_Storage_Pool (Ptr_Typ);
- -- Access subtypes must use the storage pool of their base type
-
- elsif Ekind (Typ) = E_Access_Subtype then
- declare
- Base_Typ : constant Entity_Id := Base_Type (Typ);
-
- begin
- if No (Associated_Storage_Pool (Base_Typ)) then
- Pool_Id := Get_Global_Pool_For_Access_Type (Base_Typ);
- Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
- else
- Pool_Id := Associated_Storage_Pool (Base_Typ);
- end if;
- end;
-
-- The default choice is the global pool
else
- Pool_Id := Get_Global_Pool_For_Access_Type (Typ);
- Set_Associated_Storage_Pool (Typ, Pool_Id);
+ Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
+ Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
-- Generate:
- -- Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+ -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access);
Append_To (Actions,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
+ New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Coll_Id, Loc),
+ New_Reference_To (Fin_Mas_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
- Set_Associated_Collection (Typ, Coll_Id);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
- -- A finalization collection created for an anonymous access type
- -- must be inserted before a context-dependent node.
+ -- A finalization master created for an anonymous access type must be
+ -- inserted before a context-dependent node.
if Present (Ins_Node) then
Push_Scope (Encl_Scope);
@@ -1024,12 +1019,12 @@
Append_Freeze_Actions (Typ, Actions);
-- If there's a pool created locally for the access type, then we
- -- need to ensure that the collection gets created after the pool
- -- object, because otherwise we can have a forward reference, so
- -- we force the collection actions to be inserted and analyzed after
- -- the pool entity. Note that both the access type and its designated
- -- type may have already been frozen and had their freezing actions
- -- analyzed at this point. (This seems a little unclean.???)
+ -- need to ensure that the master gets created after the pool object,
+ -- because otherwise we can have a forward reference, so we force the
+ -- master actions to be inserted and analyzed after the pool entity.
+ -- Note that both the access type and its designated type may have
+ -- already been frozen and had their freezing actions analyzed at
+ -- this point. (This seems a little unclean.???)
elsif VM_Target = No_VM
and then Scope (Pool_Id) = Scope (Typ)
@@ -1040,7 +1035,7 @@
Insert_Actions (Parent (Typ), Actions);
end if;
end;
- end Build_Finalization_Collection;
+ end Build_Finalization_Master;
---------------------
-- Build_Finalizer --
@@ -1933,15 +1928,15 @@
end if;
-- Inspect the freeze node of an access-to-controlled type and
- -- look for a delayed finalization collection. This case arises
- -- when the freeze actions are inserted at a later time than the
+ -- look for a delayed finalization master. This case arises when
+ -- the freeze actions are inserted at a later time than the
-- expansion of the context. Since Build_Finalizer is never called
- -- on a single construct twice, the collection will be ultimately
+ -- on a single construct twice, the master will be ultimately
-- left out and never finalized. This is also needed for freeze
-- actions of designated types themselves, since in some cases the
- -- finalization collection is associated with a designated type's
+ -- finalization master is associated with a designated type's
-- freeze node rather than that of the access type (see handling
- -- for freeze actions in Build_Finalization_Collection).
+ -- for freeze actions in Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
@@ -1958,12 +1953,12 @@
-- Freeze nodes are considered to be identical to packages
-- and blocks in terms of nesting. The difference is that
- -- a finalization collection created inside the freeze node
- -- is at the same nesting level as the node itself.
+ -- a finalization master created inside the freeze node is
+ -- at the same nesting level as the node itself.
Process_Declarations (Actions (Decl), Preprocess);
- -- The freeze node contains a finalization collection
+ -- The freeze node contains a finalization master
if Preprocess
and then Top_Level
@@ -2086,11 +2081,12 @@
-- following cleanup code:
--
-- if BIPallocfrom > Secondary_Stack'Pos
- -- and then BIPcollection /= null
+ -- and then BIPfinalizationmaster /= null
-- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
- -- for Ptr_Typ'Storage_Pool use Base_Pool (BIPcollection);
+ -- for Ptr_Typ'Storage_Pool
+ -- use Base_Pool (BIPfinalizationmaster);
--
-- begin
-- Free (Ptr_Typ (Temp));
@@ -2118,12 +2114,13 @@
function Build_BIP_Cleanup_Stmts
(Func_Id : Entity_Id) return Node_Id
is
- Collect : constant Entity_Id :=
- Build_In_Place_Formal (Func_Id, BIP_Collection);
- Decls : constant List_Id := New_List;
- Obj_Typ : constant Entity_Id := Etype (Func_Id);
- Temp_Id : constant Entity_Id :=
- Entity (Prefix (Name (Parent (Obj_Id))));
+ Decls : constant List_Id := New_List;
+ Fin_Mas_Id : constant Entity_Id :=
+ Build_In_Place_Formal
+ (Func_Id, BIP_Finalization_Master);
+ Obj_Typ : constant Entity_Id := Etype (Func_Id);
+ Temp_Id : constant Entity_Id :=
+ Entity (Prefix (Name (Parent (Obj_Id))));
Cond : Node_Id;
Free_Blk : Node_Id;
@@ -2133,7 +2130,7 @@
begin
-- Generate:
- -- Pool_Id renames Base_Pool (BIPcollection.all).all;
+ -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
@@ -2150,10 +2147,10 @@
New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Collect, Loc)))))));
+ Prefix => New_Reference_To (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
- -- caller's collection.
+ -- caller's finalization master.
-- Generate:
-- type Ptr_Typ is access Obj_Typ;
@@ -2167,11 +2164,11 @@
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
- -- Perform minor decoration in order to set the collection and the
+ -- Perform minor decoration in order to set the master and the
-- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
- Set_Associated_Collection (Ptr_Typ, Collect);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create an explicit free statement. Note that the free uses the
@@ -2203,18 +2200,18 @@
Statements => New_List (Free_Stmt)));
-- Generate:
- -- if BIPcollection /= null then
+ -- if BIPfinalizationmaster /= null then
Cond :=
Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Collect, Loc),
+ Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc));
-- For constrained or tagged results escalate the condition to
-- include the allocation format. Generate:
--
-- if BIPallocform > Secondary_Stack'Pos
- -- and then BIPcollection /= null
+ -- and then BIPfinalizationmaster /= null
-- then
if not Is_Constrained (Obj_Typ)
@@ -2590,11 +2587,13 @@
-- If we are dealing with a return object of a build-in-place
-- function, generate the following cleanup statements:
--
- -- if BIPallocfrom > Secondary_Stack'Pos then
+ -- if BIPallocfrom > Secondary_Stack'Pos
+ -- and then BIPfinalizationmaster /= null
+ -- then
-- declare
-- type Ptr_Typ is access Obj_Typ;
-- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPcollection.all).all;
+ -- Base_Pool (BIPfinalizationmaster.all).all;
--
-- begin
-- Free (Ptr_Typ (Temp));
@@ -2602,17 +2601,15 @@
-- end if;
--
-- The generated code effectively detaches the temporary from the
- -- caller finalization chain and deallocates the object. This is
+ -- caller finalization master and deallocates the object. This is
-- disabled on .NET/JVM because pools are not supported.
- -- H505-021 This needs to be revisited on .NET/JVM
-
if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
declare
Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
begin
if Is_Build_In_Place_Function (Func_Id)
- and then Needs_BIP_Collection (Func_Id)
+ and then Needs_BIP_Finalization_Master (Func_Id)
then
Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
end if;
@@ -4632,7 +4629,7 @@
Name =>
New_Reference_To (RTE (RE_Attach), Loc),
Parameter_Associations => New_List (
- New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+ New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
end Make_Attach_Call;
@@ -6849,17 +6846,16 @@
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
end if;
- -- For types that are both controlled and have controlled components,
- -- generate a call to Deep_Finalize.
+ -- Derivations from [Limited_]Controlled
- elsif Is_Controlled (Utyp)
- and then Has_Controlled_Component (Utyp)
- then
- Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+ elsif Is_Controlled (Utyp) then
+ if Has_Controlled_Component (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+ else
+ Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ end if;
- -- For types that are not controlled themselves, but contain controlled
- -- components or can be extended by types with controlled components,
- -- create a call to Deep_Finalize.
+ -- Class-wide types, interfaces and types with controlled components
elsif Is_Class_Wide_Type (Typ)
or else Is_Interface (Typ)
@@ -6871,11 +6867,13 @@
Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
end if;
- -- For types that are derived from Controlled and do not have controlled
- -- components, build a call to Finalize.
+ -- Tagged types
+ elsif Is_Tagged_Type (Utyp) then
+ Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
+
else
- Fin_Id := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
+ raise Program_Error;
end if;
if Present (Fin_Id) then
@@ -6927,6 +6925,9 @@
--------------------------------
procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Proc_Id : Entity_Id;
+
begin
-- Nothing to do if the type is not controlled or it already has a
-- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
@@ -6934,6 +6935,7 @@
-- do not need the Finalize_Address primitive.
if not Needs_Finalization (Typ)
+ or else Is_Abstract_Type (Typ)
or else Present (TSS (Typ, TSS_Finalize_Address))
or else
(Is_Class_Wide_Type (Typ)
@@ -6943,48 +6945,42 @@
return;
end if;
- declare
- Loc : constant Source_Ptr := Sloc (Typ);
- Proc_Id : Entity_Id;
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Make_TSS_Name (Typ, TSS_Finalize_Address));
- begin
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Make_TSS_Name (Typ, TSS_Finalize_Address));
+ -- Generate:
+ -- procedure <Typ>FD (V : System.Address) is
+ -- begin
+ -- declare
+ -- type Pnn is access all Typ;
+ -- for Pnn'Storage_Size use 0;
+ -- begin
+ -- [Deep_]Finalize (Pnn (V).all);
+ -- end;
+ -- end TypFD;
- -- Generate:
- -- procedure TypFD (V : System.Address) is
- -- begin
- -- declare
- -- type Pnn is access all Typ;
- -- for Pnn'Storage_Size use 0;
- -- begin
- -- [Deep_]Finalize (Pnn (V).all);
- -- end;
- -- end TypFD;
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)))),
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_V),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Address), Loc)))),
+ Declarations => No_List,
- Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements =>
+ Make_Finalize_Address_Stmts (Typ))));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- Make_Finalize_Address_Stmts (Typ))));
-
- Set_TSS (Typ, Proc_Id);
- end;
+ Set_TSS (Typ, Proc_Id);
end Make_Finalize_Address_Body;
---------------------------------
@@ -7415,86 +7411,6 @@
Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
end Make_Local_Deep_Finalize;
- ----------------------------------------
- -- Make_Set_Finalize_Address_Ptr_Call --
- ----------------------------------------
-
- function Make_Set_Finalize_Address_Ptr_Call
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Ptr_Typ : Entity_Id) return Node_Id
- is
- Desig_Typ : constant Entity_Id :=
- Available_View (Designated_Type (Ptr_Typ));
- Utyp : Entity_Id;
-
- begin
- -- If the context is a class-wide allocator, we use the class-wide type
- -- to obtain the proper Finalize_Address routine.
-
- if Is_Class_Wide_Type (Desig_Typ) then
- Utyp := Desig_Typ;
-
- else
- Utyp := Typ;
-
- if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
- Utyp := Full_View (Utyp);
- end if;
-
- if Is_Concurrent_Type (Utyp) then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
- end if;
-
- Utyp := Underlying_Type (Base_Type (Utyp));
-
- -- Deal with non-tagged derivation of private views. If the parent is
- -- now known to be protected, the finalization routine is the one
- -- defined on the corresponding record of the ancestor (corresponding
- -- records do not automatically inherit operations, but maybe they
- -- should???)
-
- if Is_Untagged_Derivation (Typ) then
- if Is_Protected_Type (Typ) then
- Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
- else
- Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
-
- if Is_Protected_Type (Utyp) then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
- end if;
- end if;
-
- -- If the underlying_type is a subtype, we are dealing with the
- -- completion of a private type. We need to access the base type and
- -- generate a conversion to it.
-
- if Utyp /= Base_Type (Utyp) then
- pragma Assert (Is_Private_Type (Typ));
-
- Utyp := Base_Type (Utyp);
- end if;
-
- -- Generate:
- -- Set_Finalize_Address_Ptr
- -- (<Ptr_Typ>FC, <Utyp>FD'Unrestricted_Access);
-
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
-
- Parameter_Associations => New_List (
- New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
-
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
- Attribute_Name => Name_Unrestricted_Access)));
- end Make_Set_Finalize_Address_Ptr_Call;
-
--------------------------
-- Make_Transient_Block --
--------------------------
===================================================================
@@ -40,15 +40,15 @@
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
-- that take care of finalization management at run-time.
- procedure Build_Finalization_Collection
+ procedure Build_Finalization_Master
(Typ : Entity_Id;
Ins_Node : Node_Id := Empty;
Encl_Scope : Entity_Id := Empty);
- -- Build a finalization collection for an access type. The designated type
- -- may not necessarely be controlled or need finalization actions. The
- -- routine creates a wrapper around a user-defined storage pool or the
- -- general storage pool for access types. Ins_Nod and Encl_Scope are used
- -- in conjunction with anonymous access types. Ins_Node designates the
+ -- Build a finalization master for an access type. The designated type may
+ -- not necessarely be controlled or need finalization actions. The routine
+ -- creates a wrapper around a user-defined storage pool or the general
+ -- storage pool for access types. Ins_Nod and Encl_Scope are used in
+ -- conjunction with anonymous access types. Ins_Node designates the
-- insertion point before which the collection should be added. Encl_Scope
-- is the scope of the context, either the enclosing record or the scope
-- of the related function.
@@ -173,18 +173,6 @@
-- Create a special version of Deep_Finalize with identifier Nam. The
-- routine has state information and can parform partial finalization.
- function Make_Set_Finalize_Address_Ptr_Call
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Ptr_Typ : Entity_Id) return Node_Id;
- -- Generate the following call:
- --
- -- Set_Finalize_Address_Ptr (<Ptr_Typ>FC, <Typ>FD'Unrestricted_Access);
- --
- -- where Finalize_Address is the corresponding TSS primitive of type Typ
- -- and Ptr_Typ is the access type of the related allocation. Loc is the
- -- source location of the related allocator.
-
--------------------------------------------
-- Task and Protected Object finalization --
--------------------------------------------
===================================================================
@@ -332,6 +332,9 @@
Desig_Typ : constant Entity_Id :=
Available_View (Designated_Type (Ptr_Typ));
+ function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
+ -- Locate TSS primitive Finalize_Address in type Typ
+
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- reference in it, otherwise return the original expression.
@@ -340,6 +343,57 @@
-- Determine whether subprogram Subp denotes a custom allocate or
-- deallocate.
+ ---------------------------
+ -- Find_Finalize_Address --
+ ---------------------------
+
+ function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
+ Utyp : Entity_Id := Typ;
+
+ begin
+ if Is_Private_Type (Utyp)
+ and then Present (Full_View (Utyp))
+ then
+ Utyp := Full_View (Utyp);
+ end if;
+
+ if Is_Concurrent_Type (Utyp) then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+
+ Utyp := Underlying_Type (Base_Type (Utyp));
+
+ -- Deal with non-tagged derivation of private views. If the parent is
+ -- now known to be protected, the finalization routine is the one
+ -- defined on the corresponding record of the ancestor (corresponding
+ -- records do not automatically inherit operations, but maybe they
+ -- should???)
+
+ if Is_Untagged_Derivation (Typ) then
+ if Is_Protected_Type (Typ) then
+ Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
+ else
+ Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
+
+ if Is_Protected_Type (Utyp) then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+ end if;
+ end if;
+
+ -- If the underlying_type is a subtype, we are dealing with the
+ -- completion of a private type. We need to access the base type and
+ -- generate a conversion to it.
+
+ if Utyp /= Base_Type (Utyp) then
+ pragma Assert (Is_Private_Type (Typ));
+
+ Utyp := Base_Type (Utyp);
+ end if;
+
+ return TSS (Utyp, TSS_Finalize_Address);
+ end Find_Finalize_Address;
+
-----------------
-- Find_Object --
-----------------
@@ -375,8 +429,7 @@
function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
begin
-- Look for a subprogram body with only one statement which is a
- -- call to one of the Allocate / Deallocate routines in package
- -- Ada.Finalization.Heap_Management.
+ -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
if Ekind (Subp) = E_Procedure
and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
@@ -394,8 +447,8 @@
Proc := Entity (Name (First (Statements (HSS))));
return
- Is_RTE (Proc, RE_Allocate)
- or else Is_RTE (Proc, RE_Deallocate);
+ Is_RTE (Proc, RE_Allocate_Any_Controlled)
+ or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
end if;
end;
end if;
@@ -430,137 +483,191 @@
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
Actuals : List_Id;
- Collect_Act : Node_Id;
- Collect_Id : Entity_Id;
- Collect_Typ : Entity_Id;
+ Fin_Addr_Id : Entity_Id;
+ Fin_Mas_Act : Node_Id;
+ Fin_Mas_Id : Entity_Id;
+ Fin_Mas_Typ : Entity_Id;
Proc_To_Call : Entity_Id;
begin
- -- When dealing with an access subtype, use the collection of the
- -- base type.
+ -- When dealing with an access subtype, always use the base type
+ -- since it carries all the attributes.
if Ekind (Ptr_Typ) = E_Access_Subtype then
- Collect_Typ := Base_Type (Ptr_Typ);
+ Fin_Mas_Typ := Base_Type (Ptr_Typ);
else
- Collect_Typ := Ptr_Typ;
+ Fin_Mas_Typ := Ptr_Typ;
end if;
- Collect_Id := Associated_Collection (Collect_Typ);
- Collect_Act := New_Reference_To (Collect_Id, Loc);
+ Actuals := New_List;
- -- Handle the case where the collection is actually a pointer to a
- -- collection. This case arises in build-in-place functions.
+ -- Step 1: Construct all the actuals for the call to library routine
+ -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
- if Is_Access_Type (Etype (Collect_Id)) then
- Collect_Act :=
- Make_Explicit_Dereference (Loc,
- Prefix => Collect_Act);
- end if;
+ -- a) Storage pool
- -- Create the actuals for the call to Allocate / Deallocate
+ Append_To (Actuals,
+ New_Reference_To (Associated_Storage_Pool (Fin_Mas_Typ), Loc));
- Actuals := New_List (
- Collect_Act,
- New_Reference_To (Addr_Id, Loc),
- New_Reference_To (Size_Id, Loc),
- New_Reference_To (Alig_Id, Loc));
+ if Is_Allocate then
- -- Generate a run-time check to determine whether a class-wide object
- -- is truly controlled.
+ -- b) Subpool
- if Is_Class_Wide_Type (Desig_Typ)
- or else Is_Generic_Actual_Type (Desig_Typ)
- then
- declare
- Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
- Flag_Expr : Node_Id;
- Param : Node_Id;
- Temp : Node_Id;
+ if Present (Subpool_Handle_Name (Expr)) then
+ Append_To (Actuals,
+ New_Reference_To (Entity (Subpool_Handle_Name (Expr)), Loc));
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
- begin
- if Is_Allocate then
- Temp := Find_Object (Expression (Expr));
+ -- c) Finalization master
+
+ if Needs_Finalization (Desig_Typ) then
+ Fin_Mas_Id := Finalization_Master (Fin_Mas_Typ);
+ Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
+
+ -- Handle the case where the master is actually a pointer to a
+ -- master. This case arises in build-in-place functions.
+
+ if Is_Access_Type (Etype (Fin_Mas_Id)) then
+ Append_To (Actuals, Fin_Mas_Act);
else
- Temp := Expr;
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => Fin_Mas_Act,
+ Attribute_Name => Name_Unrestricted_Access));
end if;
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
- -- Processing for generic actuals
+ -- d) Finalize_Address
- if Is_Generic_Actual_Type (Desig_Typ) then
- Flag_Expr :=
- New_Reference_To (Boolean_Literals
- (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
+ Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
- -- Processing for subtype indications
+ if Present (Fin_Addr_Id) then
+ Append_To (Actuals,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Fin_Addr_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Append_To (Actuals, Make_Null (Loc));
+ end if;
+ end if;
- elsif Nkind (Temp) in N_Has_Entity
- and then Is_Type (Entity (Temp))
- then
- Flag_Expr :=
- New_Reference_To (Boolean_Literals
- (Needs_Finalization (Entity (Temp))), Loc);
+ -- e) Address
+ -- f) Storage_Size
+ -- g) Alignment
- -- Generate a runtime check to test the controlled state of an
- -- object for the purposes of allocation / deallocation.
+ Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
+ Append_To (Actuals, New_Reference_To (Size_Id, Loc));
+ Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
- else
- -- The following case arises when allocating through an
- -- interface class-wide type, generate:
- --
- -- Temp.all
+ -- h) Is_Controlled
- if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
- Param :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Relocate_Node (Temp));
+ -- Generate a run-time check to determine whether a class-wide object
+ -- is truly controlled.
- -- Generate:
- -- Temp'Tag
+ if Needs_Finalization (Desig_Typ) then
+ if Is_Class_Wide_Type (Desig_Typ)
+ or else Is_Generic_Actual_Type (Desig_Typ)
+ then
+ declare
+ Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
+ Flag_Expr : Node_Id;
+ Param : Node_Id;
+ Temp : Node_Id;
+ begin
+ if Is_Allocate then
+ Temp := Find_Object (Expression (Expr));
else
- Param :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Relocate_Node (Temp),
- Attribute_Name => Name_Tag);
+ Temp := Expr;
end if;
- -- Generate:
- -- Needs_Finalization (Param)
+ -- Processing for generic actuals
- Flag_Expr :=
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Needs_Finalization), Loc),
- Parameter_Associations => New_List (Param));
- end if;
+ if Is_Generic_Actual_Type (Desig_Typ) then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
- -- Create the temporary which represents the finalization state
- -- of the expression. Generate:
- --
- -- F : constant Boolean := <Flag_Expr>;
+ -- Processing for subtype indications
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Flag_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression => Flag_Expr));
+ elsif Nkind (Temp) in N_Has_Entity
+ and then Is_Type (Entity (Temp))
+ then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Entity (Temp))), Loc);
- -- The flag acts as the fifth actual
+ -- Generate a runtime check to test the controlled state of
+ -- an object for the purposes of allocation / deallocation.
- Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
- end;
+ else
+ -- The following case arises when allocating through an
+ -- interface class-wide type, generate:
+ --
+ -- Temp.all
+
+ if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
+ Param :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Relocate_Node (Temp));
+
+ -- Generate:
+ -- Temp'Tag
+
+ else
+ Param :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (Temp),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ -- Generate:
+ -- Needs_Finalization (<Param>)
+
+ Flag_Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+ Parameter_Associations => New_List (Param));
+ end if;
+
+ -- Create the temporary which represents the finalization
+ -- state of the expression. Generate:
+ --
+ -- F : constant Boolean := <Flag_Expr>;
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => Flag_Expr));
+
+ -- The flag acts as the last actual
+
+ Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
+ end;
+ end if;
+ else
+ Append_To (Actuals, New_Reference_To (Standard_False, Loc));
end if;
+ -- Step 2: Build a wrapper Allocate / Deallocate which internally
+ -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
+
-- Select the proper routine to call
if Is_Allocate then
- Proc_To_Call := RTE (RE_Allocate);
+ Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
else
- Proc_To_Call := RTE (RE_Deallocate);
+ Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
end if;
-- Create a custom Allocate / Deallocate routine which has identical
@@ -611,10 +718,6 @@
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
-
- -- Allocate / Deallocate
- -- (<Ptr_Typ collection>, A, S, L[, F]);
-
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Proc_To_Call, Loc),
@@ -3752,7 +3855,7 @@
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
-- Do not consider transient objects allocated on the heap since they
- -- are attached to a finalization collection.
+ -- are attached to a finalization master.
and then not Is_Allocated (Obj_Id)
@@ -6431,16 +6534,16 @@
return True;
end if;
- -- Inspect the freeze node of an access-to-controlled type and
- -- look for a delayed finalization collection. This case arises
- -- when the freeze actions are inserted at a later time than the
- -- expansion of the context. Since Build_Finalizer is never called
- -- on a single construct twice, the collection will be ultimately
- -- left out and never finalized. This is also needed for freeze
- -- actions of designated types themselves, since in some cases the
- -- finalization collection is associated with a designated type's
- -- freeze node rather than that of the access type (see handling
- -- for freeze actions in Build_Finalization_Collection).
+ -- Inspect the freeze node of an access-to-controlled type and look
+ -- for a delayed finalization master. This case arises when the
+ -- freeze actions are inserted at a later time than the expansion of
+ -- the context. Since Build_Finalizer is never called on a single
+ -- construct twice, the master will be ultimately left out and never
+ -- finalized. This is also needed for freeze actions of designated
+ -- types themselves, since in some cases the finalization master is
+ -- associated with a designated type's freeze node rather than that
+ -- of the access type (see handling for freeze actions in
+ -- Build_Finalization_Master).
elsif Nkind (Decl) = N_Freeze_Entity
and then Present (Actions (Decl))
@@ -6451,9 +6554,9 @@
and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization
(Available_View (Designated_Type (Typ))))
- or else
- (Is_Type (Typ)
- and then Needs_Finalization (Typ)))
+ or else
+ (Is_Type (Typ)
+ and then Needs_Finalization (Typ)))
and then Requires_Cleanup_Actions
(Actions (Decl), For_Package, Nested_Constructs)
then
===================================================================
@@ -202,21 +202,7 @@
-- allocation, N is the declaration of the temporary variable which
-- represents the expression of the original allocator node, otherwise N
-- must be a free statement. If flag Is_Allocate is set, the generated
- -- routine is allocate, deallocate otherwise. The generated routine is:
- --
- -- F : constant Boolean := -- CW case
- -- Ada.Tags.Needs_Finalization (<Expr>'Tag); -- CW case
- --
- -- procedure Allocate / Deallocate
- -- (P : Storage_Pool;
- -- A : [out] Address; -- out is present for Allocate
- -- S : Storage_Count;
- -- L : Storage_Count)
- -- is
- -- begin
- -- Allocate / Deallocate
- -- (<Ptr_Typ collection>, A, S, L, [Needs_Header => F]);
- -- end Allocate;
+ -- routine is allocate, deallocate otherwise.
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id;
-- Build an N_Procedure_Call_Statement calling the given runtime entity.
===================================================================
@@ -195,11 +195,11 @@
-- Scope_Depth_Value Uint22
-- Shared_Var_Procs_Instance Node22
- -- Associated_Collection Node23
-- CR_Discriminant Node23
-- Entry_Cancel_Parameter Node23
-- Enum_Pos_To_Rep Node23
-- Extra_Constrained Node23
+ -- Finalization_Master Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Limited_View Node23
@@ -612,12 +612,6 @@
return Uint14 (Id);
end Alignment;
- function Associated_Collection (Id : E) return E is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Node23 (Id);
- end Associated_Collection;
-
function Associated_Formal_Package (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Package);
@@ -1075,6 +1069,12 @@
return Flag229 (Base_Type (Id));
end Can_Use_Internal_Rep;
+ function Finalization_Master (Id : E) return E is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Node23 (Root_Type (Id));
+ end Finalization_Master;
+
function Finalize_Storage_Only (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@@ -3051,12 +3051,6 @@
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
- procedure Set_Associated_Collection (Id : E; V : E) is
- begin
- pragma Assert (Is_Access_Type (Id));
- Set_Node23 (Id, V);
- end Set_Associated_Collection;
-
procedure Set_Associated_Formal_Package (Id : E; V : E) is
begin
Set_Node12 (Id, V);
@@ -3544,6 +3538,12 @@
Set_Flag229 (Id, V);
end Set_Can_Use_Internal_Rep;
+ procedure Set_Finalization_Master (Id : E; V : E) is
+ begin
+ pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
+ Set_Node23 (Id, V);
+ end Set_Finalization_Master;
+
procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
@@ -6941,16 +6941,8 @@
if Ekind (T) = E_Class_Wide_Type then
return Etype (T);
- elsif Ekind (T) = E_Class_Wide_Subtype then
- return Etype (Base_Type (T));
+ -- Other cases
- -- ??? T comes from Base_Type, how can it be a subtype?
- -- Also Base_Type is supposed to be idempotent, so either way
- -- this is equivalent to "return Etype (T)" and should be merged
- -- with the E_Class_Wide_Type case.
-
- -- All other cases
-
else
loop
Etyp := Etype (T);
@@ -8459,9 +8451,6 @@
procedure Write_Field23_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Access_Kind =>
- Write_Str ("Associated_Collection");
-
when E_Discriminant =>
Write_Str ("CR_Discriminant");
@@ -8475,6 +8464,9 @@
E_Variable =>
Write_Str ("Extra_Constrained");
+ when Access_Kind =>
+ Write_Str ("Finalization_Master");
+
when E_Generic_Function |
E_Generic_Package |
E_Generic_Procedure =>
===================================================================
@@ -427,12 +427,6 @@
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
-
-- Associated_Formal_Package (Node12)
-- Present in packages that are the actuals of formal_packages. Points
-- to the entity in the declaration for the formal package.
@@ -1144,6 +1138,13 @@
-- must be retrieved through the entity designed by this field instead of
-- being computed.
+-- Finalization_Master (Node23) [root type only]
+-- Present in access-to-controlled or access-to-class-wide types. The
+-- field contains the entity of the finalization master which handles
+-- dynamically allocated controlled objects referenced by the access
+-- type. Empty for access-to-subprogram types. Empty for access types
+-- whose designated type does not need finalization actions.
+
-- Finalize_Storage_Only (Flag158) [base type only]
-- Present in all types. Set on direct controlled types to which a
-- valid Finalize_Storage_Only pragma applies. This flag is also set on
@@ -4943,7 +4944,7 @@
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (base type only)
- -- Associated_Collection (Node23) (base type only)
+ -- Finalization_Master (Node23) (base type only)
-- Has_Pragma_Controlled (Flag27) (base type only)
-- Has_Storage_Size_Clause (Flag23) (base type only)
-- Is_Access_Constant (Flag69)
@@ -4971,7 +4972,7 @@
-- E_Anonymous_Access_Type
-- Storage_Size_Variable (Node15) ??? is this needed ???
-- Directly_Designated_Type (Node20)
- -- Associated_Collection (Node23)
+ -- Finalization_Master (Node23)
-- (plus type attributes)
-- E_Array_Type
@@ -5278,7 +5279,7 @@
-- Master_Id (Node17)
-- Directly_Designated_Type (Node20)
-- Associated_Storage_Pool (Node22) (root type only)
- -- Associated_Collection (Node23)
+ -- Finalization_Master (Node23) (root type only)
-- (plus type attributes)
-- E_Generic_In_Parameter
@@ -5974,7 +5975,6 @@
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Alignment (Id : E) return U;
- function Associated_Collection (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
function Associated_Node_For_Itype (Id : E) return N;
function Associated_Storage_Pool (Id : E) return E;
@@ -6050,6 +6050,7 @@
function Extra_Formal (Id : E) return E;
function Extra_Formals (Id : E) return E;
function Can_Use_Internal_Rep (Id : E) return B;
+ function Finalization_Master (Id : E) return E;
function Finalize_Storage_Only (Id : E) return B;
function Finalizer (Id : E) return E;
function First_Entity (Id : E) return E;
@@ -6563,7 +6564,6 @@
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
- procedure Set_Associated_Collection (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
procedure Set_Associated_Node_For_Itype (Id : E; V : N);
procedure Set_Associated_Storage_Pool (Id : E; V : E);
@@ -6637,6 +6637,7 @@
procedure Set_Extra_Formal (Id : E; V : E);
procedure Set_Extra_Formals (Id : E; V : E);
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
+ procedure Set_Finalization_Master (Id : E; V : E);
procedure Set_Finalize_Storage_Only (Id : E; V : B := True);
procedure Set_Finalizer (Id : E; V : E);
procedure Set_First_Entity (Id : E; V : E);
@@ -7259,7 +7260,6 @@
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
- pragma Inline (Associated_Collection);
pragma Inline (Associated_Formal_Package);
pragma Inline (Associated_Node_For_Itype);
pragma Inline (Associated_Storage_Pool);
@@ -7335,6 +7335,7 @@
pragma Inline (Extra_Formal);
pragma Inline (Extra_Formals);
pragma Inline (Can_Use_Internal_Rep);
+ pragma Inline (Finalization_Master);
pragma Inline (Finalizer);
pragma Inline (First_Entity);
pragma Inline (First_Exit_Statement);
@@ -7703,7 +7704,6 @@
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
- pragma Inline (Set_Associated_Collection);
pragma Inline (Set_Associated_Formal_Package);
pragma Inline (Set_Associated_Node_For_Itype);
pragma Inline (Set_Associated_Storage_Pool);
@@ -7778,6 +7778,7 @@
pragma Inline (Set_Extra_Formal);
pragma Inline (Set_Extra_Formals);
pragma Inline (Set_Can_Use_Internal_Rep);
+ pragma Inline (Set_Finalization_Master);
pragma Inline (Set_Finalizer);
pragma Inline (Set_First_Entity);
pragma Inline (Set_First_Exit_Statement);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2011, 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- --
@@ -293,9 +293,6 @@
elsif U_Id in Ada_Dispatching_Child then
Name_Buffer (16) := '.';
- elsif U_Id in Ada_Finalization_Child then
- Name_Buffer (17) := '.';
-
elsif U_Id in Ada_Interrupts_Child then
Name_Buffer (15) := '.';
@@ -324,6 +321,10 @@
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
+ if U_Id in System_Storage_Pools_Child then
+ Name_Buffer (21) := '.';
+ end if;
+
if U_Id in System_Strings_Child then
Name_Buffer (15) := '.';
end if;
===================================================================
@@ -48,9 +48,6 @@
-- eventually, packages implementing delays will be found relative to
-- the package that declares the time type.
- -- Names of the form Ada_Finalization_xxx are second level children of
- -- Ada.Finalization.
-
-- Names of the form Ada_Interrupts_xxx are second level children of
-- Ada.Interrupts. This is needed for Ada.Interrupts.Names which is used
-- by pragma Interrupt_State.
@@ -80,6 +77,9 @@
-- name is System.xxx. For example, the name System_Str_Concat refers to
-- package System.Str_Concat.
+ -- Names of the form System_Storage_Pools_xxx are second level children
+ -- of the package System.Storage_Pools.
+
-- Names of the form System_Strings_xxx are second level children of the
-- package System.Strings.
@@ -140,10 +140,6 @@
Ada_Dispatching_EDF,
- -- Children of Ada.Finalization
-
- Ada_Finalization_Heap_Management,
-
-- Children of Ada.Interrupts
Ada_Interrupts_Names,
@@ -249,6 +245,7 @@
System_Fat_VAX_D_Float,
System_Fat_VAX_F_Float,
System_Fat_VAX_G_Float,
+ System_Finalization_Masters,
System_Finalization_Root,
System_Fore,
System_Img_Bool,
@@ -374,6 +371,10 @@
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Storage_Pools
+
+ System_Storage_Pools_Subpools,
+
-- Children of System.Strings
System_Strings_Stream_Ops,
@@ -403,10 +404,6 @@
range Ada_Dispatching_EDF .. Ada_Dispatching_EDF;
-- Range of values for children of Ada.Dispatching
- subtype Ada_Finalization_Child is Ada_Child range
- Ada_Finalization_Heap_Management .. Ada_Finalization_Heap_Management;
- -- Range of values for children of Ada.Finalization
-
subtype Ada_Interrupts_Child is Ada_Child range
Ada_Interrupts_Names .. Ada_Interrupts_Names;
-- Range of values for children of Ada.Interrupts
@@ -443,6 +440,9 @@
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
+ subtype System_Storage_Pools_Child is RTU_Id
+ range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools;
+
subtype System_Strings_Child is RTU_Id
range System_Strings_Stream_Ops .. System_Strings_Stream_Ops;
@@ -521,17 +521,6 @@
RE_Reraise_Occurrence_No_Defer, -- Ada.Exceptions
RE_Save_Occurrence, -- Ada.Exceptions
- RE_Add_Offset_To_Address, -- Ada.Finalization.Heap_Management
- RE_Allocate, -- Ada.Finalization.Heap_Management
- RE_Attach, -- Ada.Finalization.Heap_Management
- RE_Base_Pool, -- Ada.Finalization.Heap_Management
- RE_Deallocate, -- Ada.Finalization.Heap_Management
- RE_Detach, -- Ada.Finalization.Heap_Management
- RE_Finalization_Collection, -- Ada.Finalization.Heap_Management
- RE_Finalization_Collection_Ptr, -- Ada.Finalization.Heap_Management
- RE_Set_Finalize_Address_Ptr, -- Ada.Finalization.Heap_Management
- RE_Set_Storage_Pool_Ptr, -- Ada.Finalization.Heap_Management
-
RE_Interrupt_ID, -- Ada.Interrupts
RE_Is_Reserved, -- Ada.Interrupts
RE_Is_Attached, -- Ada.Interrupts
@@ -805,6 +794,14 @@
RE_Attr_VAX_G_Float, -- System.Fat_VAX_G_Float
RE_Fat_VAX_G, -- System.Fat_VAX_G_Float
+ RE_Add_Offset_To_Address, -- System.Finalization_Masters
+ RE_Attach, -- System.Finalization_Masters
+ RE_Base_Pool, -- System.Finalization_Masters
+ RE_Detach, -- System.Finalization_Masters
+ RE_Finalization_Master, -- System.Finalization_Masters
+ RE_Finalization_Master_Ptr, -- System.Finalization_Masters
+ RE_Set_Base_Pool, -- System.Finalization_Masters
+
RE_Root_Controlled, -- System.Finalization_Root
RE_Root_Controlled_Ptr, -- System.Finalization_Root
@@ -1327,10 +1324,16 @@
RE_Storage_Offset, -- System.Storage_Elements
RE_To_Address, -- System.Storage_Elements
+ RE_Allocate_Any, -- System.Storage_Pools
+ RE_Deallocate_Any, -- System.Storage_Pools
RE_Root_Storage_Pool, -- System.Storage_Pools
- RE_Allocate_Any, -- System.Storage_Pools,
- RE_Deallocate_Any, -- System.Storage_Pools,
+ RE_Allocate_Any_Controlled, -- System.Storage_Pools.Subpools
+ RE_Deallocate_Any_Controlled, -- System.Storage_Pools.Subpools
+ RE_Root_Storage_Pool_With_Subpools, -- System.Storage_Pools.Subpools
+ RE_Root_Subpool, -- System.Storage_Pools.Subpools
+ RE_Subpool_Handle, -- System.Storage_Pools.Subpools
+
RE_I_AD, -- System.Stream_Attributes
RE_I_AS, -- System.Stream_Attributes
RE_I_B, -- System.Stream_Attributes
@@ -1704,17 +1707,6 @@
RE_Reraise_Occurrence_No_Defer => Ada_Exceptions,
RE_Save_Occurrence => Ada_Exceptions,
- RE_Add_Offset_To_Address => Ada_Finalization_Heap_Management,
- RE_Allocate => Ada_Finalization_Heap_Management,
- RE_Attach => Ada_Finalization_Heap_Management,
- RE_Base_Pool => Ada_Finalization_Heap_Management,
- RE_Deallocate => Ada_Finalization_Heap_Management,
- RE_Detach => Ada_Finalization_Heap_Management,
- RE_Finalization_Collection => Ada_Finalization_Heap_Management,
- RE_Finalization_Collection_Ptr => Ada_Finalization_Heap_Management,
- RE_Set_Finalize_Address_Ptr => Ada_Finalization_Heap_Management,
- RE_Set_Storage_Pool_Ptr => Ada_Finalization_Heap_Management,
-
RE_Interrupt_ID => Ada_Interrupts,
RE_Is_Reserved => Ada_Interrupts,
RE_Is_Attached => Ada_Interrupts,
@@ -1988,6 +1980,14 @@
RE_Attr_VAX_G_Float => System_Fat_VAX_G_Float,
RE_Fat_VAX_G => System_Fat_VAX_G_Float,
+ RE_Add_Offset_To_Address => System_Finalization_Masters,
+ RE_Attach => System_Finalization_Masters,
+ RE_Base_Pool => System_Finalization_Masters,
+ RE_Detach => System_Finalization_Masters,
+ RE_Finalization_Master => System_Finalization_Masters,
+ RE_Finalization_Master_Ptr => System_Finalization_Masters,
+ RE_Set_Base_Pool => System_Finalization_Masters,
+
RE_Root_Controlled => System_Finalization_Root,
RE_Root_Controlled_Ptr => System_Finalization_Root,
@@ -2510,10 +2510,16 @@
RE_Storage_Offset => System_Storage_Elements,
RE_To_Address => System_Storage_Elements,
- RE_Root_Storage_Pool => System_Storage_Pools,
RE_Allocate_Any => System_Storage_Pools,
RE_Deallocate_Any => System_Storage_Pools,
+ RE_Root_Storage_Pool => System_Storage_Pools,
+ RE_Allocate_Any_Controlled => System_Storage_Pools_Subpools,
+ RE_Deallocate_Any_Controlled => System_Storage_Pools_Subpools,
+ RE_Root_Storage_Pool_With_Subpools => System_Storage_Pools_Subpools,
+ RE_Root_Subpool => System_Storage_Pools_Subpools,
+ RE_Subpool_Handle => System_Storage_Pools_Subpools,
+
RE_I_AD => System_Stream_Attributes,
RE_I_AS => System_Stream_Attributes,
RE_I_B => System_Stream_Attributes,
===================================================================
@@ -1432,27 +1432,27 @@
end loop;
end;
- -- We add finalization collections to access types whose designated
- -- types require finalization. This is normally done when freezing
- -- the type, but this misses recursive type definitions where the
- -- later members of the recursion introduce controlled components
- -- (such as can happen when incomplete types are involved), as well
- -- cases where a component type is private and the controlled full
- -- type occurs after the access type is frozen. Cases that don't
- -- need a finalization collection are generic formal types (the
- -- actual type will have it) and types with Java and CIL conventions,
- -- since those are used for API bindings. (Are there any other cases
- -- that should be excluded here???)
+ -- We add finalization masters to access types whose designated types
+ -- require finalization. This is normally done when freezing the
+ -- type, but this misses recursive type definitions where the later
+ -- members of the recursion introduce controlled components (such as
+ -- can happen when incomplete types are involved), as well cases
+ -- where a component type is private and the controlled full type
+ -- occurs after the access type is frozen. Cases that don't need a
+ -- finalization master are generic formal types (the actual type will
+ -- have it) and types with Java and CIL conventions, since those are
+ -- used for API bindings. (Are there any other cases that should be
+ -- excluded here???)
elsif Is_Access_Type (E)
and then Comes_From_Source (E)
and then not Is_Generic_Type (E)
and then Needs_Finalization (Designated_Type (E))
- and then No (Associated_Collection (E))
+ and then No (Finalization_Master (E))
and then Convention (Designated_Type (E)) /= Convention_Java
and then Convention (Designated_Type (E)) /= Convention_CIL
then
- Build_Finalization_Collection (E);
+ Build_Finalization_Master (E);
end if;
Next_Entity (E);
@@ -2029,7 +2029,7 @@
Next_Entity (Comp);
end loop;
- -- Deal with Bit_Order aspect specifying a non-default bit order
+ -- Deal with pragma Bit_Order setting non-standard bit order
if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
if not Placed_Component then
===================================================================
@@ -0,0 +1,473 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Unchecked_Deallocation;
+
+with System.Finalization_Masters; use System.Finalization_Masters;
+with System.Soft_Links; use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body System.Storage_Pools.Subpools is
+
+ procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
+ -- Attach a subpool node to a pool
+
+ procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr);
+
+ procedure Detach (N : not null SP_Node_Ptr);
+ -- Unhook a subpool node from an arbitrary subpool list
+
+ --------------
+ -- Allocate --
+ --------------
+
+ overriding procedure Allocate
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Storage_Address : out System.Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count)
+ is
+ begin
+ -- ??? The use of Allocate is very dangerous as it does not handle
+ -- controlled objects properly. Perhaps we should provide an
+ -- implementation which raises Program_Error instead.
+
+ -- Dispatch to the user-defined implementations of Allocate_From_Subpool
+ -- and Default_Subpool_For_Pool.
+
+ Allocate_From_Subpool
+ (Root_Storage_Pool_With_Subpools'Class (Pool),
+ Storage_Address,
+ Size_In_Storage_Elements,
+ Alignment,
+ Default_Subpool_For_Pool
+ (Root_Storage_Pool_With_Subpools'Class (Pool)));
+ end Allocate;
+
+ -----------------------------
+ -- Allocate_Any_Controlled --
+ -----------------------------
+
+ procedure Allocate_Any_Controlled
+ (Pool : in out Root_Storage_Pool'Class;
+ Context_Subpool : Subpool_Handle := null;
+ Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
+ Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
+ Addr : out System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean := True)
+ is
+ -- ??? This membership test gives the wrong result when Pool has
+ -- subpools.
+
+ Is_Subpool_Allocation : constant Boolean :=
+ Pool in Root_Storage_Pool_With_Subpools;
+
+ Master : Finalization_Master_Ptr := null;
+ N_Addr : Address;
+ N_Ptr : FM_Node_Ptr;
+ N_Size : Storage_Count;
+ Subpool : Subpool_Handle := null;
+
+ begin
+ -- Step 1: Pool-related runtime checks
+
+ -- Allocation on a pool_with_subpools. In this scenario there is a
+ -- master for each subpool.
+
+ if Is_Subpool_Allocation then
+
+ -- Case of an allocation without a Subpool_Handle. Dispatch to the
+ -- implementation of Default_Subpool_For_Pool.
+
+ if Context_Subpool = null then
+ Subpool :=
+ Default_Subpool_For_Pool
+ (Root_Storage_Pool_With_Subpools'Class (Pool));
+
+ -- Ensure proper ownership
+
+ if Subpool.Owner /=
+ Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+ then
+ raise Program_Error with "incorrect owner of default subpool";
+ end if;
+
+ -- Allocation with a Subpool_Handle
+
+ else
+ Subpool := Context_Subpool;
+
+ -- Ensure proper ownership
+
+ if Subpool.Owner /=
+ Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
+ then
+ raise Program_Error with "incorrect owner of subpool";
+ end if;
+ end if;
+
+ Master := Subpool.Master'Unchecked_Access;
+
+ -- Allocation on a simple pool. In this scenario there is a master for
+ -- each access-to-controlled type. No context subpool should be present.
+
+ else
+
+ -- If the master is missing, then the expansion of the access type
+ -- failed to create one. This is a serious error.
+
+ if Context_Master = null then
+ raise Program_Error with "missing master in pool allocation";
+
+ -- If a subpool is present, then this is the result of erroneous
+ -- allocator expansion. This is not a serious error, but it should
+ -- still be detected.
+
+ elsif Context_Subpool /= null then
+ raise Program_Error with "subpool not required in pool allocation";
+ end if;
+
+ Master := Context_Master;
+ end if;
+
+ -- Step 2: Master-related runtime checks
+
+ -- Allocation of a descendant from [Limited_]Controlled, a class-wide
+ -- object or a record with controlled components.
+
+ if Is_Controlled then
+
+ -- Do not allow the allocation of controlled objects while the
+ -- associated master is being finalized.
+
+ if Master.Finalization_Started then
+ raise Program_Error with "allocation after finalization started";
+ end if;
+
+ -- The size must acount for the hidden header preceding the object
+
+ N_Size := Storage_Size + Header_Size;
+
+ -- Non-controlled allocation
+
+ else
+ N_Size := Storage_Size;
+ end if;
+
+ -- Step 3: Allocation of object
+
+ -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
+ -- implementation of Allocate_From_Subpool.
+
+ if Is_Subpool_Allocation then
+ Allocate_From_Subpool
+ (Root_Storage_Pool_With_Subpools'Class (Pool),
+ N_Addr, N_Size, Alignment, Subpool);
+
+ -- For descendants of Root_Storage_Pool, dispatch to the implementation
+ -- of Allocate.
+
+ else
+ Allocate (Pool, N_Addr, N_Size, Alignment);
+ end if;
+
+ -- Step 4: Attachment
+
+ if Is_Controlled then
+
+ -- Map the allocated memory into a FM_Node record. This converts the
+ -- top of the allocated bits into a list header.
+
+ N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+
+ -- Check whether primitive Finalize_Address is available. If it is
+ -- not, then either the expansion of the designated type failed or
+ -- the expansion of the allocator failed. This is a serious error.
+
+ if Fin_Address = null then
+ raise Program_Error
+ with "primitive Finalize_Address not available";
+ end if;
+
+ N_Ptr.Finalize_Address := Fin_Address;
+
+ -- Prepend the allocated object to the finalization master
+
+ Attach (N_Ptr, Master.Objects'Unchecked_Access);
+
+ -- Move the address from the hidden list header to the start of the
+ -- object. This operation effectively hides the list header.
+
+ Addr := N_Addr + Header_Offset;
+ else
+ Addr := N_Addr;
+ end if;
+ end Allocate_Any_Controlled;
+
+ ------------
+ -- Attach --
+ ------------
+
+ procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
+ begin
+ Lock_Task.all;
+
+ L.Next.Prev := N;
+ N.Next := L.Next;
+ L.Next := N;
+ N.Prev := L;
+
+ Unlock_Task.all;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Attach;
+
+ -------------------------------
+ -- Deallocate_Any_Controlled --
+ -------------------------------
+
+ procedure Deallocate_Any_Controlled
+ (Pool : in out Root_Storage_Pool'Class;
+ Addr : System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean := True)
+ is
+ N_Addr : Address;
+ N_Ptr : FM_Node_Ptr;
+ N_Size : Storage_Count;
+
+ begin
+ -- Step 1: Detachment
+
+ if Is_Controlled then
+
+ -- Move the address from the object to the beginning of the list
+ -- header.
+
+ N_Addr := Addr - Header_Offset;
+
+ -- Convert the bits preceding the object into a list header
+
+ N_Ptr := Address_To_FM_Node_Ptr (N_Addr);
+
+ -- Detach the object from the related finalization master. This
+ -- action does not need to know the prior context used during
+ -- allocation.
+
+ Detach (N_Ptr);
+
+ -- The size of the deallocated object must include the size of the
+ -- hidden list header.
+
+ N_Size := Storage_Size + Header_Size;
+ else
+ N_Addr := Addr;
+ N_Size := Storage_Size;
+ end if;
+
+ -- Step 2: Deallocation
+
+ -- Dispatch to the proper implementation of Deallocate. This action
+ -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
+ -- implementations.
+
+ Deallocate (Pool, N_Addr, N_Size, Alignment);
+ end Deallocate_Any_Controlled;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (N : not null SP_Node_Ptr) is
+ begin
+ -- N must be attached to some list
+
+ pragma Assert (N.Next /= null and then N.Prev /= null);
+
+ Lock_Task.all;
+
+ N.Prev.Next := N.Next;
+ N.Next.Prev := N.Prev;
+
+ Unlock_Task.all;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Detach;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize
+ (Pool : in out Root_Storage_Pool_With_Subpools)
+ is
+ Curr_Ptr : SP_Node_Ptr;
+ Ex_Occur : Exception_Occurrence;
+ Next_Ptr : SP_Node_Ptr;
+ Raised : Boolean := False;
+
+ begin
+ -- Uninitialized pools do not have subpools and do not contain objects
+ -- of any kind.
+
+ if not Pool.Initialized then
+ return;
+ end if;
+
+ -- It is possible for multiple tasks to cause the finalization of a
+ -- common pool. Allow only one task to finalize the contents.
+
+ if Pool.Finalization_Started then
+ return;
+ end if;
+
+ -- Lock the pool to prevent the creation of additional subpools while
+ -- the available ones are finalized. The pool remains locked because
+ -- either it is about to be deallocated or the associated access type
+ -- is about to go out of scope.
+
+ Pool.Finalization_Started := True;
+
+ -- Skip the dummy head
+
+ Curr_Ptr := Pool.Subpools.Next;
+ while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
+ Next_Ptr := Curr_Ptr.Next;
+
+ -- Remove the subpool node from the subpool list
+
+ Detach (Curr_Ptr);
+
+ -- Finalize the current subpool
+
+ begin
+ Finalize_Subpool (Curr_Ptr.Subpool);
+
+ exception
+ when Fin_Occur : others =>
+ if not Raised then
+ Raised := True;
+ Save_Occurrence (Ex_Occur, Fin_Occur);
+ end if;
+ end;
+
+ -- Since subpool nodes are not allocated on the owner pool, they must
+ -- be explicitly destroyed.
+
+ Free (Curr_Ptr);
+
+ Curr_Ptr := Next_Ptr;
+ end loop;
+
+ -- If the finalization of a particular master failed, reraise the
+ -- exception now.
+
+ if Raised then
+ Reraise_Occurrence (Ex_Occur);
+ end if;
+ end Finalize;
+
+ ----------------------
+ -- Finalize_Subpool --
+ ----------------------
+
+ procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is
+ begin
+ Finalize (Subpool.Master);
+ end Finalize_Subpool;
+
+ ---------------------
+ -- Pool_Of_Subpool --
+ ---------------------
+
+ function Pool_Of_Subpool (Subpool : not null Subpool_Handle)
+ return access Root_Storage_Pool_With_Subpools'Class is
+ begin
+ return Subpool.Owner;
+ end Pool_Of_Subpool;
+
+ -------------------------
+ -- Set_Pool_Of_Subpool --
+ -------------------------
+
+ procedure Set_Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle;
+ Pool : in out Root_Storage_Pool_With_Subpools'Class)
+ is
+ N_Ptr : SP_Node_Ptr;
+
+ begin
+ if not Pool.Initialized then
+
+ -- The dummy head must point to itself in both directions
+
+ Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
+ Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
+ Pool.Initialized := True;
+ end if;
+
+ -- If the subpool is already owned, raise Program_Error. This is a
+ -- direct violation of the RM rules.
+
+ if Subpool.Owner /= null then
+ raise Program_Error with "subpool already belongs to a pool";
+ end if;
+
+ -- Prevent the creation of a new subpool while the owner is being
+ -- finalized. This is a serious error.
+
+ if Pool.Finalization_Started then
+ raise Program_Error
+ with "subpool creation after finalization started";
+ end if;
+
+ -- Create a subpool node, decorate it and associate it with the subpool
+ -- list of Pool.
+
+ N_Ptr := new SP_Node;
+
+ Subpool.Owner := Pool'Unchecked_Access;
+ N_Ptr.Subpool := Subpool;
+
+ Attach (N_Ptr, Pool.Subpools'Unchecked_Access);
+ end Set_Pool_Of_Subpool;
+
+end System.Storage_Pools.Subpools;
===================================================================
@@ -0,0 +1,255 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Finalization_Masters;
+with System.Storage_Elements;
+
+package System.Storage_Pools.Subpools is
+ pragma Preelaborate (System.Storage_Pools.Subpools);
+
+ type Root_Storage_Pool_With_Subpools is abstract
+ new Root_Storage_Pool with private;
+ -- The base for all implementations of Storage_Pool_With_Subpools. This
+ -- type is Limited_Controlled by derivation. To use subpools, an access
+ -- type must be associated with an implementation descending from type
+ -- Root_Storage_Pool_With_Subpools.
+
+ type Root_Subpool is abstract tagged limited private;
+ -- The base for all implementations of Subpool. Objects of this type are
+ -- managed by the pool_with_subpools.
+
+ type Subpool_Handle is access all Root_Subpool'Class;
+ for Subpool_Handle'Storage_Size use 0;
+ -- Since subpools are limited types by definition, a handle is instead used
+ -- to manage subpool abstractions.
+
+ overriding procedure Allocate
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Storage_Address : out System.Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count);
+ -- Allocate an object described by Size_In_Storage_Elements and Alignment
+ -- on the default subpool of Pool.
+
+ procedure Allocate_From_Subpool
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Storage_Address : out System.Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Subpool : not null Subpool_Handle)
+ is abstract;
+
+ -- ??? This precondition causes errors in simple tests, disabled for now
+
+-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+ -- This routine requires implementation. Allocate an object described by
+ -- Size_In_Storage_Elements and Alignment on a subpool.
+
+ function Create_Subpool
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Storage_Size : Storage_Elements.Storage_Count :=
+ Storage_Elements.Storage_Count'Last)
+ return not null Subpool_Handle
+ is abstract;
+ -- This routine requires implementation. Create a subpool within the given
+ -- pool_with_subpools.
+
+ overriding procedure Deallocate
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Storage_Address : System.Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count)
+ is null;
+
+ procedure Deallocate_Subpool
+ (Pool : in out Root_Storage_Pool_With_Subpools;
+ Subpool : in out Subpool_Handle)
+ is abstract;
+
+ -- ??? This precondition causes errors in simple tests, disabled for now
+
+-- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
+ -- This routine requires implementation. Reclaim the storage a particular
+ -- subpool occupies in a pool_with_subpools. This routine is called by
+ -- Ada.Unchecked_Deallocate_Subpool.
+
+ function Default_Subpool_For_Pool
+ (Pool : Root_Storage_Pool_With_Subpools)
+ return not null Subpool_Handle
+ is abstract;
+ -- This routine requires implementation. Returns a common subpool used for
+ -- allocations without Subpool_Handle_name in the allocator.
+
+ function Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle)
+ return access Root_Storage_Pool_With_Subpools'Class;
+ -- Return the owner of the subpool
+
+ procedure Set_Pool_Of_Subpool
+ (Subpool : not null Subpool_Handle;
+ Pool : in out Root_Storage_Pool_With_Subpools'Class);
+ -- Set the owner of the subpool. This is intended to be called from
+ -- Create_Subpool or similar subpool constructors. Raises Program_Error
+ -- if the subpool already belongs to a pool.
+
+private
+ -- Model
+ -- Pool_With_Subpools
+ -- +----> +---------------------+ <----+
+ -- | +---------- Subpools | |
+ -- | | +---------------------+ |
+ -- | | : User data : |
+ -- | | '.....................' |
+ -- | | |
+ -- | | SP_Node SP_Node |
+ -- | +-> +-------+ +-------+ |
+ -- | | Prev <-----> Prev | |
+ -- | +-------+ +-------+ |
+ -- | | Next <---->| Next | |
+ -- | +-------+ +-------+ |
+ -- | +----Subpool| |Subpool----+ |
+ -- | | +-------+ +-------+ | |
+ -- | | | |
+ -- | | Subpool Subpool | |
+ -- | +-> +-------+ +-------+ <-+ |
+ -- +------- Owner | | Owner -------+
+ -- +-------+ +-------+
+ -- +------------------- Master| | Master---------------+
+ -- | +-------+ +-------+ |
+ -- | : User : : User : |
+ -- | : Data : : Data : |
+ -- | '.......' '.......' |
+ -- | |
+ -- | Heap |
+ -- .. | ..................................................... | ..
+ -- : | | :
+ -- : | Object Object Object Object | :
+ -- : +-> +------+ +------+ +------+ +------+ <-+ :
+ -- : | Prev <--> Prev <--> Prev | | Prev | :
+ -- : +------+ +------+ +------+ +------+ :
+ -- : | Next <--> Next <--> Next | | Next | :
+ -- : +------+ +------+ +------+ +------+ :
+ -- : | FA | | FA | | FA | | FA | :
+ -- : +------+ +------+ +------+ +------+ :
+ -- : : : : : : : : : :
+ -- : : : : : : : : : :
+ -- : '......' '......' '......' '......' :
+ -- : :
+ -- '.............................................................'
+
+ -- Subpool list types. Each pool_with_subpools contains a list of subpools.
+
+ type SP_Node;
+ type SP_Node_Ptr is access all SP_Node;
+
+ type SP_Node is record
+ Prev : SP_Node_Ptr := null;
+ Next : SP_Node_Ptr := null;
+ Subpool : Subpool_Handle := null;
+ end record;
+
+ -- Root_Storage_Pool_With_Subpools internal structure
+
+ type Root_Storage_Pool_With_Subpools is abstract
+ new Root_Storage_Pool with
+ record
+ Initialized : Boolean := False;
+ pragma Atomic (Initialized);
+ -- Even though this type is derived from Limited_Controlled, overriding
+ -- Initialize would have no effect since the type is abstract. Routine
+ -- Set_Pool_Of_Subpool is tasked with the initialization of a pool with
+ -- subpools because it has to be called at some point. This flag is used
+ -- to prevent the resetting of the subpool chain.
+
+ Subpools : aliased SP_Node;
+ -- A doubly linked list of subpools
+
+ Finalization_Started : Boolean := False;
+ pragma Atomic (Finalization_Started);
+ -- A flag which prevents the creation of new subpools while the master
+ -- pool is being finalized. The flag needs to be atomic because it is
+ -- accessed without Lock_Task / Unlock_Task.
+ end record;
+
+ type Any_Storage_Pool_With_Subpools_Ptr
+ is access all Root_Storage_Pool_With_Subpools'Class;
+ for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;
+
+ -- A subpool is an abstraction layer which sits on top of a pool. It
+ -- contains links to all controlled objects allocated on a particular
+ -- subpool.
+
+ type Root_Subpool is abstract tagged limited record
+ Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
+ -- A reference to the master pool_with_subpools
+
+ Master : aliased System.Finalization_Masters.Finalization_Master;
+ -- A collection of controlled objects
+ end record;
+
+ -- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
+ -- to Allocate_Any.
+
+ procedure Allocate_Any_Controlled
+ (Pool : in out Root_Storage_Pool'Class;
+ Context_Subpool : Subpool_Handle := null;
+ Context_Master : Finalization_Masters.Finalization_Master_Ptr := null;
+ Fin_Address : Finalization_Masters.Finalize_Address_Ptr := null;
+ Addr : out System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean := True);
+ -- Compiler interface. This version of Allocate handles all possible cases,
+ -- either on a pool or a pool_with_subpools.
+
+ procedure Deallocate_Any_Controlled
+ (Pool : in out Root_Storage_Pool'Class;
+ Addr : System.Address;
+ Storage_Size : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count;
+ Is_Controlled : Boolean := True);
+ -- Compiler interface. This version of Deallocate handles all possible
+ -- cases, either from a pool or a pool_with_subpools.
+
+ overriding procedure Finalize
+ (Pool : in out Root_Storage_Pool_With_Subpools);
+ -- Iterate over all subpools of Pool, detach them one by one and finalize
+ -- their masters. This action first detaches a controlled object from a
+ -- particular master, then invokes its Finalize_Address primitive.
+
+ procedure Finalize_Subpool (Subpool : not null Subpool_Handle);
+ -- Finalize the master of a subpool
+
+end System.Storage_Pools.Subpools;
===================================================================
@@ -0,0 +1,36 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- ??? What is the header version here, see a-uncdea.adb. No GPL?
+
+with System.Storage_Pools.Subpools; use System.Storage_Pools.Subpools;
+
+procedure Ada.Unchecked_Deallocate_Subpool
+ (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle)
+is
+begin
+ -- Finalize all controlled objects allocated on the input subpool
+
+ -- ??? It is awkward to create a child of Storage_Pools.Subpools for the
+ -- sole purpose of exporting Finalize_Subpool.
+
+-- Finalize_Subpool (Subpool);
+
+ -- Dispatch to the user-defined implementation of Deallocate_Subpool
+
+ Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool);
+end Ada.Unchecked_Deallocate_Subpool;
===================================================================
@@ -0,0 +1,23 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. In accordance with the copyright of that document, you can freely --
+-- copy and modify this specification, provided that if you redistribute a --
+-- modified version, any changes that you have made are clearly indicated. --
+-- --
+------------------------------------------------------------------------------
+
+-- ??? What is the header version here, see a-uncdea.ads. No GPL?
+
+with System.Storage_Pools.Subpools;
+
+procedure Ada.Unchecked_Deallocate_Subpool
+ (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle);
===================================================================
@@ -444,12 +444,15 @@
return;
end if;
+ -- ??? Now that finalization masters act as heterogeneous lists, it
+ -- might be worthed to revisit the global master approach.
+
-- Processing for anonymous access-to-controlled types. These access
- -- types receive a special collection which appears on the declarations
- -- of the enclosing semantic unit.
+ -- types receive a special finalization master which appears in the
+ -- declarations of the enclosing semantic unit.
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then No (Associated_Collection (Ptr_Typ))
+ and then No (Finalization_Master (Ptr_Typ))
and then
(not Restriction_Active (No_Nested_Finalization)
or else Is_Library_Level_Entity (Ptr_Typ))
@@ -466,7 +469,7 @@
Scop := Corresponding_Spec (Parent (Parent (Parent (Scop))));
end if;
- Build_Finalization_Collection
+ Build_Finalization_Master
(Typ => Ptr_Typ,
Ins_Node => First_Declaration_Of_Current_Unit,
Encl_Scope => Scop);
@@ -481,7 +484,7 @@
-- Since the temporary object reuses the original allocator, generate a
-- custom Allocate routine for the temporary.
- if Present (Associated_Collection (Ptr_Typ)) then
+ if Present (Finalization_Master (Ptr_Typ)) then
Build_Allocate_Deallocate_Proc
(N => Temp_Decl,
Is_Allocate => True);
@@ -858,14 +861,14 @@
Complete_Controlled_Allocation (Temp_Decl);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
- -- Attach the object to the associated finalization collection.
+ -- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
-- no support pools and can't benefit from internally generated
-- Allocate / Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
- and then Present (Associated_Collection (PtrT))
+ and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call (
@@ -888,14 +891,14 @@
Insert_Action (N, Temp_Decl);
Complete_Controlled_Allocation (Temp_Decl);
- -- Attach the object to the associated finalization collection.
+ -- Attach the object to the associated finalization master.
-- This is done manually on .NET/JVM since those compilers do
-- no support pools and can't benefit from internally generated
-- Allocate / Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
- and then Present (Associated_Collection (PtrT))
+ and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call (
@@ -931,8 +934,7 @@
-- Inherit the allocation-related attributes from the original
-- access type.
- Set_Associated_Collection (Def_Id,
- Associated_Collection (PtrT));
+ Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
Set_Associated_Storage_Pool (Def_Id,
Associated_Storage_Pool (PtrT));
@@ -1083,25 +1085,6 @@
Prefix => New_Reference_To (Temp, Loc))),
Typ => T));
end if;
-
- -- Generate:
- -- Set_Finalize_Address_Ptr
- -- (Collection, <Finalize_Address>'Unrestricted_Access)
-
- -- Since .NET/JVM compilers do not support address arithmetic,
- -- this call is skipped. The same is done for CodePeer because
- -- Finalize_Address is never generated.
-
- if VM_Target = No_VM
- and then not CodePeer_Mode
- and then Present (Associated_Collection (PtrT))
- then
- Insert_Action (N,
- Make_Set_Finalize_Address_Ptr_Call
- (Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
- end if;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
@@ -1139,14 +1122,14 @@
Complete_Controlled_Allocation (Temp_Decl);
Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
- -- Attach the object to the associated finalization collection. This
- -- is done manually on .NET/JVM since those compilers do no support
+ -- Attach the object to the associated finalization master. Thisis
+ -- done manually on .NET/JVM since those compilers do no support
-- pools and cannot benefit from internally generated Allocate and
-- Deallocate procedures.
if VM_Target /= No_VM
and then Is_Controlled (DesigT)
- and then Present (Associated_Collection (PtrT))
+ and then Present (Finalization_Master (PtrT))
then
Insert_Action (N,
Make_Attach_Call
@@ -3564,7 +3547,7 @@
-- do not support pools, this step is skipped.
if VM_Target = No_VM
- and then Present (Associated_Collection (PtrT))
+ and then Present (Finalization_Master (PtrT))
then
Build_Allocate_Deallocate_Proc
(N => Parent (N),
@@ -3858,39 +3841,22 @@
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T));
- if Present (Associated_Collection (PtrT)) then
+ -- Special processing for .NET/JVM, the allocated object is
+ -- attached to the finalization master. Generate:
- -- Special processing for .NET/JVM, the allocated object
- -- is attached to the finalization collection. Generate:
+ -- Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
- -- Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
+ -- Types derived from [Limited_]Controlled are the only
+ -- ones considered since they have fields Prev and Next.
- -- Types derived from [Limited_]Controlled are the only
- -- ones considered since they have fields Prev and Next.
-
- if VM_Target /= No_VM then
- if Is_Controlled (T) then
- Insert_Action (N,
- Make_Attach_Call
- (Obj_Ref => New_Copy_Tree (Init_Arg1),
- Ptr_Typ => PtrT));
- end if;
-
- -- Default case, generate:
-
- -- Set_Finalize_Address_Ptr
- -- (Pool, <Finalize_Address>'Unrestricted_Access)
-
- -- Do not generate the above for CodePeer compilations
- -- because Finalize_Address is never built.
-
- elsif not CodePeer_Mode then
- Insert_Action (N,
- Make_Set_Finalize_Address_Ptr_Call
- (Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
- end if;
+ if VM_Target /= No_VM
+ and then Present (Finalization_Master (PtrT))
+ and then Is_Controlled (T)
+ then
+ Insert_Action (N,
+ Make_Attach_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Ptr_Typ => PtrT));
end if;
end if;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 2009-2011, 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- --
@@ -37,13 +37,12 @@
procedure Allocate_Any
(Pool : in out Root_Storage_Pool'Class;
- Storage_Address : out Address;
+ Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
- Allocate
- (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+ Allocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
end Allocate_Any;
--------------------
@@ -52,12 +51,12 @@
procedure Deallocate_Any
(Pool : in out Root_Storage_Pool'Class;
- Storage_Address : Address;
+ Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is
begin
- Deallocate
- (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+ Deallocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
end Deallocate_Any;
+
end System.Storage_Pools;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,14 +44,14 @@
procedure Allocate
(Pool : in out Root_Storage_Pool;
- Storage_Address : out Address;
+ Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is abstract;
procedure Deallocate
(Pool : in out Root_Storage_Pool;
- Storage_Address : Address;
+ Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count)
is abstract;
@@ -62,6 +62,13 @@
is abstract;
private
+ type Root_Storage_Pool is abstract
+ new Ada.Finalization.Limited_Controlled with null record;
+
+ -- ??? Are these two still needed? It might be possible to use Subpools.
+ -- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled
+ -- objects.
+
-- The following two procedures support the use of class-wide pool
-- objects in storage pools. When a local type is given a class-wide
-- storage pool, allocation and deallocation for the type must dispatch
@@ -71,16 +78,14 @@
procedure Allocate_Any
(Pool : in out Root_Storage_Pool'Class;
- Storage_Address : out Address;
+ Storage_Address : out System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
procedure Deallocate_Any
(Pool : in out Root_Storage_Pool'Class;
- Storage_Address : Address;
+ Storage_Address : System.Address;
Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
Alignment : System.Storage_Elements.Storage_Count);
- type Root_Storage_Pool is abstract
- new Ada.Finalization.Limited_Controlled with null record;
end System.Storage_Pools;
===================================================================
@@ -110,14 +110,14 @@
-- Adds Extra_Actual as a named parameter association for the formal
-- Extra_Formal in Subprogram_Call.
- procedure Add_Collection_Actual_To_Build_In_Place_Call
+ procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty);
-- Ada 2005 (AI-318-02): If the result type of a build-in-place call needs
-- finalization actions, add an actual parameter which is a pointer to the
- -- finalization collection of the caller. If Ptr_Typ is left Empty, this
- -- will result in an automatic "null" value for the actual.
+ -- finalization master of the caller. If Ptr_Typ is left Empty, this will
+ -- result in an automatic "null" value for the actual.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
@@ -340,30 +340,30 @@
(Function_Call, Alloc_Form_Formal, Alloc_Form_Actual);
end Add_Alloc_Form_Actual_To_Build_In_Place_Call;
- --------------------------------------------------
- -- Add_Collection_Actual_To_Build_In_Place_Call --
- --------------------------------------------------
+ -----------------------------------------------------------
+ -- Add_Finalization_Master_Actual_To_Build_In_Place_Call --
+ -----------------------------------------------------------
- procedure Add_Collection_Actual_To_Build_In_Place_Call
+ procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call : Node_Id;
Func_Id : Entity_Id;
Ptr_Typ : Entity_Id := Empty)
is
begin
- if not Needs_BIP_Collection (Func_Id) then
+ if not Needs_BIP_Finalization_Master (Func_Id) then
return;
end if;
declare
Formal : constant Entity_Id :=
- Build_In_Place_Formal (Func_Id, BIP_Collection);
+ Build_In_Place_Formal (Func_Id, BIP_Finalization_Master);
Loc : constant Source_Ptr := Sloc (Func_Call);
Actual : Node_Id;
Desig_Typ : Entity_Id;
begin
- -- Case where the context does not require an actual collection
+ -- Case where the context does not require an actual master
if No (Ptr_Typ) then
Actual := Make_Null (Loc);
@@ -372,9 +372,9 @@
Desig_Typ := Directly_Designated_Type (Ptr_Typ);
-- Check for a library-level access type whose designated type has
- -- supressed finalization. Such an access types lack a collection.
+ -- supressed finalization. Such an access types lack a master.
-- Pass a null actual to the callee in order to signal a missing
- -- collection.
+ -- master.
if Is_Library_Level_Entity (Ptr_Typ)
and then Finalize_Storage_Only (Desig_Typ)
@@ -385,28 +385,28 @@
elsif Needs_Finalization (Desig_Typ) then
- -- The general mechanism of creating finalization collections
- -- for anonymous access types is disabled by default, otherwise
- -- collections will pop all over the place. Such types use
- -- context-specific collections.
+ -- The general mechanism of creating finalization masters for
+ -- anonymous access types is disabled by default, otherwise
+ -- finalization masters will pop all over the place. Such types
+ -- use context-specific masters.
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then No (Associated_Collection (Ptr_Typ))
+ and then No (Finalization_Master (Ptr_Typ))
then
- Build_Finalization_Collection
+ Build_Finalization_Master
(Typ => Ptr_Typ,
Ins_Node => Associated_Node_For_Itype (Ptr_Typ),
Encl_Scope => Scope (Ptr_Typ));
end if;
- -- Access-to-controlled types should always have a collection
+ -- Access-to-controlled types should always have a master
- pragma Assert (Present (Associated_Collection (Ptr_Typ)));
+ pragma Assert (Present (Finalization_Master (Ptr_Typ)));
Actual :=
Make_Attribute_Reference (Loc,
Prefix =>
- New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+ New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Attribute_Name => Name_Unrestricted_Access);
-- Tagged types
@@ -423,7 +423,7 @@
Add_Extra_Actual_To_Call (Func_Call, Formal, Actual);
end;
- end Add_Collection_Actual_To_Build_In_Place_Call;
+ end Add_Finalization_Master_Actual_To_Build_In_Place_Call;
------------------------------
-- Add_Extra_Actual_To_Call --
@@ -559,15 +559,15 @@
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
- when BIP_Alloc_Form =>
+ when BIP_Alloc_Form =>
return "BIPalloc";
- when BIP_Collection =>
- return "BIPcollection";
- when BIP_Master =>
+ when BIP_Finalization_Master =>
+ return "BIPfinalizationmaster";
+ when BIP_Master =>
return "BIPmaster";
- when BIP_Activation_Chain =>
+ when BIP_Activation_Chain =>
return "BIPactivationchain";
- when BIP_Object_Access =>
+ when BIP_Object_Access =>
return "BIPaccess";
end case;
end BIP_Formal_Suffix;
@@ -2105,10 +2105,10 @@
end if;
end if;
- -- Detect the following code in Ada.Finalization.Heap_Management only
- -- on .NET/JVM targets:
+ -- Detect the following code in System.Finalization_Masters only on
+ -- .NET/JVM targets:
--
- -- procedure Finalize (Collection : in out Finalization_Collection) is
+ -- procedure Finalize (Master : in out Finalization_Master) is
-- begin
-- . . .
-- begin
@@ -2124,7 +2124,7 @@
and then Ekind (Scope (Curr_S)) = E_Procedure
and then Chars (Scope (Curr_S)) = Name_Finalize
and then Etype (First_Formal (Scope (Curr_S))) =
- RTE (RE_Finalization_Collection)
+ RTE (RE_Finalization_Master)
then
declare
Deep_Fin : constant Entity_Id :=
@@ -4393,20 +4393,20 @@
Ret_Typ : Entity_Id;
Alloc_Expr : Node_Id) return Node_Id;
-- Create the statements necessary to allocate a return object on the
- -- caller's collection. The collection is available through implicit
- -- parameter BIPcollection.
+ -- caller's master. The master is available through implicit parameter
+ -- BIPfinalizationmaster.
--
- -- if BIPcollection /= null then
+ -- if BIPfinalizationmaster /= null then
-- declare
-- type Ptr_Typ is access Ret_Typ;
-- for Ptr_Typ'Storage_Pool use
- -- Base_Pool (BIPcollection.all).all;
+ -- Base_Pool (BIPfinalizationmaster.all).all;
-- Local : Ptr_Typ;
--
-- begin
-- procedure Allocate (...) is
-- begin
- -- Ada.Finalization.Heap_Management.Allocate (...);
+ -- System.Storage_Pools.Subpools.Allocate_Any (...);
-- end Allocate;
--
-- Local := <Alloc_Expr>;
@@ -4439,17 +4439,18 @@
is
begin
-- Processing for build-in-place object allocation. This is disabled
- -- on .NET/JVM because pools are not supported.
+ -- on .NET/JVM because the targets do not support pools.
if VM_Target = No_VM
and then Is_Build_In_Place_Function (Func_Id)
and then Needs_Finalization (Ret_Typ)
then
declare
- Collect : constant Entity_Id :=
- Build_In_Place_Formal (Func_Id, BIP_Collection);
- Decls : constant List_Id := New_List;
- Stmts : constant List_Id := New_List;
+ Decls : constant List_Id := New_List;
+ Fin_Mas_Id : constant Entity_Id :=
+ Build_In_Place_Formal
+ (Func_Id, BIP_Finalization_Master);
+ Stmts : constant List_Id := New_List;
Local_Id : Entity_Id;
Pool_Id : Entity_Id;
@@ -4457,7 +4458,7 @@
begin
-- Generate:
- -- Pool_Id renames Base_Pool (BIPcollection.all).all;
+ -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
Pool_Id := Make_Temporary (Loc, 'P');
@@ -4474,11 +4475,12 @@
New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Collect, Loc)))))));
+ Prefix =>
+ New_Reference_To (Fin_Mas_Id, Loc)))))));
-- Create an access type which uses the storage pool of the
- -- caller's collection. This additional type is necessary
- -- because the collection cannot be associated with the type
+ -- caller's master. This additional type is necessary because
+ -- the finalization master cannot be associated with the type
-- of the temporary. Otherwise the secondary stack allocation
-- will fail.
@@ -4495,11 +4497,11 @@
Subtype_Indication =>
New_Reference_To (Ret_Typ, Loc))));
- -- Perform minor decoration in order to set the collection and
- -- the storage pool attributes.
+ -- Perform minor decoration in order to set the master and the
+ -- storage pool attributes.
Set_Ekind (Ptr_Typ, E_Access_Type);
- Set_Associated_Collection (Ptr_Typ, Collect);
+ Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create the temporary, generate:
@@ -4534,12 +4536,12 @@
New_Reference_To (Local_Id, Loc))));
-- Wrap the allocation in a block. This is further conditioned
- -- by checking the caller collection at runtime. A null value
- -- indicates a non-existent collection, most likely due to a
- -- Finalize_Storage_Only allocation.
+ -- by checking the caller finalization master at runtime. A
+ -- null value indicates a non-existent master, most likely due
+ -- to a Finalize_Storage_Only allocation.
-- Generate:
- -- if BIPcollection /= null then
+ -- if BIPfinalizationmaster /= null then
-- declare
-- <Decls>
-- begin
@@ -4551,7 +4553,7 @@
Make_If_Statement (Loc,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd => New_Reference_To (Collect, Loc),
+ Left_Opnd => New_Reference_To (Fin_Mas_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
@@ -7110,7 +7112,7 @@
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
@@ -7144,7 +7146,7 @@
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Global_Heap);
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Acc_Type);
Add_Task_Actuals_To_Build_In_Place_Call
@@ -7157,33 +7159,6 @@
(Func_Call, Function_Id, Return_Object => Empty);
end if;
- -- If the build-in-place function call returns a controlled object, the
- -- finalization collection will require a reference to routine Finalize_
- -- Address of the designated type. Setting this attribute is done in the
- -- same manner to expansion of allocators.
-
- if Needs_Finalization (Result_Subt) then
-
- -- Controlled types with supressed finalization do not need to
- -- associate the address of their Finalize_Address primitives with a
- -- collection since they do not need a collection to begin with.
-
- if Is_Library_Level_Entity (Acc_Type)
- and then Finalize_Storage_Only (Result_Subt)
- then
- null;
-
- -- Do not generate the call to Make_Set_Finalize_Address_Ptr for
- -- CodePeer compilations because Finalize_Address is never built.
-
- elsif not CodePeer_Mode then
- Insert_Action (Allocator,
- Make_Set_Finalize_Address_Ptr_Call (Loc,
- Typ => Etype (Function_Id),
- Ptr_Typ => Acc_Type));
- end if;
- end if;
-
-- Finally, replace the allocator node with a reference to the result
-- of the function call itself (which will effectively be an access
-- to the object created by the allocator).
@@ -7310,7 +7285,7 @@
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@@ -7334,7 +7309,7 @@
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@@ -7412,7 +7387,7 @@
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Func_Id, Alloc_Form => Caller_Allocation);
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Func_Id);
Add_Task_Actuals_To_Build_In_Place_Call
@@ -7625,7 +7600,7 @@
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
end if;
- Add_Collection_Actual_To_Build_In_Place_Call
+ Add_Finalization_Master_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id);
if Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement
@@ -7773,11 +7748,13 @@
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
- --------------------------
- -- Needs_BIP_Collection --
- --------------------------
+ -----------------------------------
+ -- Needs_BIP_Finalization_Master --
+ -----------------------------------
- function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean is
+ function Needs_BIP_Finalization_Master
+ (Func_Id : Entity_Id) return Boolean
+ is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
@@ -7785,6 +7762,6 @@
return
not Restriction_Active (No_Finalization)
and then Needs_Finalization (Func_Typ);
- end Needs_BIP_Collection;
+ end Needs_BIP_Finalization_Master;
end Exp_Ch6;
===================================================================
@@ -68,9 +68,9 @@
-- caller or callee, and if the callee, whether to use the secondary
-- stack or the heap. See Create_Extra_Formals.
- BIP_Collection,
+ BIP_Finalization_Master,
-- Present if result type needs finalization. Pointer to caller's
- -- finalization collection.
+ -- finalization master.
BIP_Master,
-- Present if result type contains tasks. Master associated with
@@ -163,8 +163,8 @@
-- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
-- node applied to such a function call.
- function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean;
+ function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True if the function needs a finalization
- -- collection implicit parameter.
+ -- master implicit parameter.
end Exp_Ch6;
===================================================================
@@ -230,7 +230,7 @@
return;
end if;
- -- Use the base type to perform the collection check
+ -- Use the base type to perform the check for finalization master
Typ := Etype (Expr);
@@ -248,10 +248,10 @@
-- Do not create a custom Deallocate when freeing an object with
-- suppressed finalization. In such cases the object is never attached
- -- to a collection, so it does not need to be detached. Use a regular
- -- free statement instead.
+ -- to a master, so it does not need to be detached. Use a regular free
+ -- statement instead.
- if No (Associated_Collection (Typ)) then
+ if No (Finalization_Master (Typ)) then
return;
end if;
===================================================================
@@ -6080,14 +6080,13 @@
end if;
-- In the case of functions whose result type needs finalization,
- -- add an extra formal of type Ada.Finalization.Heap_Management.
- -- Finalization_Collection_Ptr.
+ -- add an extra formal which represents the finalization master.
- if Needs_BIP_Collection (E) then
+ if Needs_BIP_Finalization_Master (E) then
Discard :=
Add_Extra_Formal
- (E, RTE (RE_Finalization_Collection_Ptr),
- E, BIP_Formal_Suffix (BIP_Collection));
+ (E, RTE (RE_Finalization_Master_Ptr),
+ E, BIP_Formal_Suffix (BIP_Finalization_Master));
end if;
-- If the result type contains tasks, we have two extra formals:
===================================================================
@@ -154,7 +154,6 @@
a-envvar$(objext) \
a-except$(objext) \
a-exctra$(objext) \
- a-fihema$(objext) \
a-finali$(objext) \
a-flteio$(objext) \
a-fwteio$(objext) \
@@ -290,6 +289,7 @@
a-tiunio$(objext) \
a-unccon$(objext) \
a-uncdea$(objext) \
+ a-undesu$(objext) \
a-wichha$(objext) \
a-wichun$(objext) \
a-widcha$(objext) \
@@ -495,6 +495,7 @@
s-ficobl$(objext) \
s-fileio$(objext) \
s-filofl$(objext) \
+ s-finmas$(objext) \
s-finroo$(objext) \
s-fishfl$(objext) \
s-flocon$(objext) \
@@ -611,6 +612,7 @@
s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
+ s-stposu$(objext) \
s-stratt$(objext) \
s-strhas$(objext) \
s-string$(objext) \
===================================================================
@@ -0,0 +1,214 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+with System.Soft_Links; use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body System.Finalization_Masters is
+
+ ---------------------------
+ -- Add_Offset_To_Address --
+ ---------------------------
+
+ function Add_Offset_To_Address
+ (Addr : System.Address;
+ Offset : System.Storage_Elements.Storage_Offset) return System.Address
+ is
+ begin
+ return System.Storage_Elements."+" (Addr, Offset);
+ end Add_Offset_To_Address;
+
+ ------------
+ -- Attach --
+ ------------
+
+ procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
+ begin
+ Lock_Task.all;
+
+ L.Next.Prev := N;
+ N.Next := L.Next;
+ L.Next := N;
+ N.Prev := L;
+
+ Unlock_Task.all;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Attach;
+
+ ---------------
+ -- Base_Pool --
+ ---------------
+
+ function Base_Pool
+ (Master : Finalization_Master) return Any_Storage_Pool_Ptr
+ is
+ begin
+ return Master.Base_Pool;
+ end Base_Pool;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (N : not null FM_Node_Ptr) is
+ begin
+ -- N must be attached to some list
+
+ pragma Assert (N.Next /= null and then N.Prev /= null);
+
+ Lock_Task.all;
+
+ N.Prev.Next := N.Next;
+ N.Next.Prev := N.Prev;
+
+ Unlock_Task.all;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Detach;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Master : in out Finalization_Master) is
+ Curr_Ptr : FM_Node_Ptr;
+ Ex_Occur : Exception_Occurrence;
+ Obj_Addr : Address;
+ Raised : Boolean := False;
+
+ begin
+ -- It is possible for multiple tasks to cause the finalization of the
+ -- same master. Let only one task finalize the objects.
+
+ if Master.Finalization_Started then
+ return;
+ end if;
+
+ -- Lock the master to prevent any allocations while the objects are
+ -- being finalized. The master remains locked because either the master
+ -- is explicitly deallocated or the associated access type is about to
+ -- go out of scope.
+
+ Master.Finalization_Started := True;
+
+ -- Skip the dummy head
+
+ Curr_Ptr := Master.Objects.Next;
+ while Curr_Ptr /= Master.Objects'Unchecked_Access loop
+ begin
+ -- If primitive Finalize_Address is not set, then the expansion of
+ -- the designated type or that of the allocator failed. This is a
+ -- serious error.
+
+ -- Note: The Program_Error must be raised from the same block as
+ -- the finalization call. If Finalize_Address is not present for
+ -- a particular object, this should not stop the finalization of
+ -- the remaining objects.
+
+ if Curr_Ptr.Finalize_Address = null then
+ raise Program_Error
+ with "primitive Finalize_Address not available";
+
+ -- Skip the list header in order to offer proper object layout for
+ -- finalization and call Finalize_Address.
+
+ else
+ Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+ Curr_Ptr.Finalize_Address (Obj_Addr);
+ end if;
+
+ exception
+ when Fin_Occur : others =>
+ if not Raised then
+ Raised := True;
+ Save_Occurrence (Ex_Occur, Fin_Occur);
+ end if;
+ end;
+
+ Curr_Ptr := Curr_Ptr.Next;
+ end loop;
+
+ -- If the finalization of a particular object failed or Finalize_Address
+ -- was not set, reraise the exception now.
+
+ if Raised then
+ Reraise_Occurrence (Ex_Occur);
+ end if;
+ end Finalize;
+
+ -----------------
+ -- Header_Size --
+ -----------------
+
+ function Header_Size return System.Storage_Elements.Storage_Count is
+ begin
+ return FM_Node'Size / Storage_Unit;
+ end Header_Size;
+
+ -------------------
+ -- Header_Offset --
+ -------------------
+
+ function Header_Offset return System.Storage_Elements.Storage_Offset is
+ begin
+ return FM_Node'Size / Storage_Unit;
+ end Header_Offset;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ overriding procedure Initialize (Master : in out Finalization_Master) is
+ begin
+ -- The dummy head must point to itself in both directions
+
+ Master.Objects.Next := Master.Objects'Unchecked_Access;
+ Master.Objects.Prev := Master.Objects'Unchecked_Access;
+ end Initialize;
+
+ -------------------
+ -- Set_Base_Pool --
+ -------------------
+
+ procedure Set_Base_Pool
+ (Master : in out Finalization_Master;
+ Pool_Ptr : Any_Storage_Pool_Ptr)
+ is
+ begin
+ Master.Base_Pool := Pool_Ptr;
+ end Set_Base_Pool;
+
+end System.Finalization_Masters;
===================================================================
@@ -0,0 +1,135 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2011, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Finalization;
+with Ada.Unchecked_Conversion;
+
+with System.Storage_Elements;
+with System.Storage_Pools;
+
+package System.Finalization_Masters is
+ pragma Preelaborate (System.Finalization_Masters);
+
+ -- A reference to primitive Finalize_Address. The expander generates an
+ -- implementation of this procedure for each controlled and class-wide
+ -- type. Since controlled objects are simply viewed as addresses once
+ -- allocated through a master, Finalize_Address provides a backward
+ -- indirection from an address to a type-specific context.
+
+ type Finalize_Address_Ptr is access procedure (Obj : System.Address);
+
+ -- Heterogeneous collection type structure. The implementation allows for
+ -- finalizable objects of different base types to be serviced by the same
+ -- master.
+
+ type FM_Node;
+ type FM_Node_Ptr is access all FM_Node;
+
+ type FM_Node is record
+ Prev : FM_Node_Ptr := null;
+ Next : FM_Node_Ptr := null;
+ Finalize_Address : Finalize_Address_Ptr := null;
+ end record;
+
+ -- A reference to any derivation from Root_Storage_Pool. Since this type
+ -- may not be used to allocate objects, its storage size is zero.
+
+ type Any_Storage_Pool_Ptr is
+ access System.Storage_Pools.Root_Storage_Pool'Class;
+ for Any_Storage_Pool_Ptr'Storage_Size use 0;
+
+ -- Finalization master type structure. A unique master is associated with
+ -- each access-to-controlled or access-to-class-wide type. Masters also act
+ -- as components of subpools.
+
+ type Finalization_Master is
+ new Ada.Finalization.Limited_Controlled with
+ record
+ Base_Pool : Any_Storage_Pool_Ptr := null;
+ -- A reference to the pool which this finalization master services. This
+ -- field is used in conjunction with the build-in-place machinery.
+
+ Objects : aliased FM_Node;
+ -- A doubly linked list which contains the headers of all controlled
+ -- objects allocated in a [sub]pool.
+
+ Finalization_Started : Boolean := False;
+ pragma Atomic (Finalization_Started);
+ -- A flag used to detect allocations which occur during the finalization
+ -- of a master. The allocations must raise Program_Error. This scenario
+ -- may arise in a multitask environment. The flag is atomic because it
+ -- is accessed without Lock_Task / Unlock_Task.
+ end record;
+
+ type Finalization_Master_Ptr is access all Finalization_Master;
+ for Finalization_Master_Ptr'Storage_Size use 0;
+
+ -- Since RTSfind cannot contain names of the form RE_"+", the following
+ -- routine serves as a wrapper around System.Storage_Elements."+".
+
+ function Add_Offset_To_Address
+ (Addr : System.Address;
+ Offset : System.Storage_Elements.Storage_Offset) return System.Address;
+
+ function Address_To_FM_Node_Ptr is
+ new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
+
+ procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
+ -- Prepend a node to a specific finalization master
+
+ function Base_Pool
+ (Master : Finalization_Master) return Any_Storage_Pool_Ptr;
+ -- Return a reference to the underlying storage pool on which the master
+ -- operates.
+
+ procedure Detach (N : not null FM_Node_Ptr);
+ -- Remove a node from an arbitrary finalization master
+
+ overriding procedure Finalize (Master : in out Finalization_Master);
+ -- Lock the master to prevent allocations during finalization. Iterate over
+ -- the list of allocated controlled objects, finalizing each one by calling
+ -- its specific Finalize_Address. In the end, deallocate the dummy head.
+
+ function Header_Size return System.Storage_Elements.Storage_Count;
+ -- Return the size of type FM_Node as Storage_Count
+
+ function Header_Offset return System.Storage_Elements.Storage_Offset;
+ -- Return the size of type FM_Node as Storage_Offset
+
+ overriding procedure Initialize (Master : in out Finalization_Master);
+ -- Initialize the dummy head of a finalization master
+
+ procedure Set_Base_Pool
+ (Master : in out Finalization_Master;
+ Pool_Ptr : Any_Storage_Pool_Ptr);
+ -- Set the underlying pool of a finalization master
+
+end System.Finalization_Masters;
===================================================================
@@ -5482,12 +5482,13 @@
Build_Slice_Assignment (Typ);
end if;
- -- ??? This may not be necessary after all
+ -- ??? Now that masters acts as heterogeneous lists, it might be
+ -- worthed to revisit the global master approach.
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
then
- Build_Finalization_Collection (Comp_Typ);
+ Build_Finalization_Master (Comp_Typ);
end if;
end if;
@@ -5581,8 +5582,8 @@
return;
end if;
- -- Generate the body of Finalize_Address. This routine is accessible
- -- through the TSS mechanism.
+ -- Create the body of TSS primitive Finalize_Address. This automatically
+ -- sets the TSS entry for the class-wide type.
Make_Finalize_Address_Body (Typ);
end Expand_Freeze_Class_Wide_Type;
@@ -6310,13 +6311,17 @@
-- compiling a CPP tagged type.
elsif not Restriction_Active (No_Dispatching_Calls) then
- Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
- Append_Freeze_Actions (Def_Id, Predef_List);
- -- Create the body of Finalize_Address, a helper routine used in
- -- conjunction with controlled objects on the heap.
+ -- Create the body of TSS primitive Finalize_Address. This must
+ -- be done before the bodies of all predefined primitives are
+ -- created. If Def_Id is limited, Stream_Input and Streap_Read
+ -- may produce build-in-place allocations and for that the
+ -- expander needs Finalize_Address.
Make_Finalize_Address_Body (Def_Id);
+
+ Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
+ Append_Freeze_Actions (Def_Id, Predef_List);
end if;
-- Ada 2005 (AI-391): If any wrappers were created for nonoverridden
@@ -6364,7 +6369,7 @@
and then Directly_Designated_Type (Comp_Typ) /= Def_Id
then
- Build_Finalization_Collection
+ Build_Finalization_Master
(Typ => Comp_Typ,
Ins_Node => Parent (Def_Id),
Encl_Scope => Scope (Def_Id));
@@ -6652,7 +6657,7 @@
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
- Build_Finalization_Collection (Def_Id);
+ Build_Finalization_Master (Def_Id);
end if;
end;
@@ -8399,7 +8404,7 @@
end if;
-- All tagged types receive their own Deep_Adjust and Deep_Finalize
- -- regardless of whether they are controlled or contain controlled
+ -- regardless of whether they are controlled or may contain controlled
-- components.
-- Do not generate the routines if finalization is disabled
@@ -8414,12 +8419,10 @@
else
if not Is_Limited_Type (Tag_Typ) then
- Append_To (Res,
- Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
+ Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
end if;
- Append_To (Res,
- Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
+ Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
end if;
Predef_List := Res;
@@ -9028,9 +9031,9 @@
-- to be (implicitly) inherited in that case because it can lead to a VM
-- exception.
- -- Do not generate stream routines for type Finalization_Collection
- -- because collection may never appear in types and therefore cannot be
- -- read or written.
+ -- Do not generate stream routines for type Finalization_Master because
+ -- a master may never appear in types and therefore cannot be read or
+ -- written.
return
(not Is_Limited_Type (Typ)
@@ -9053,7 +9056,7 @@
and then RTE_Available (RE_Tag)
and then No (Type_Without_Stream_Operation (Typ))
and then RTE_Available (RE_Root_Stream_Type)
- and then not Is_RTE (Typ, RE_Finalization_Collection);
+ and then not Is_RTE (Typ, RE_Finalization_Master);
end Stream_Operation_OK;
end Exp_Ch3;