* [COMMITTED] ada: Fix bad interaction between homogeneous finalization master and BIP protocol
@ 2024-05-07 8:00 Marc Poulhiès
0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2024-05-07 8:00 UTC (permalink / raw)
To: gcc-patches; +Cc: Eric Botcazou
From: Eric Botcazou <ebotcazou@adacore.com>
Dynamically-allocated objects that require finalization are attached to a
finalization master, which is of a (limited) controlled type declared in
the System.Finalization_Masters unit. Now there are two kinds of them:
homogeneous and heterogeneous; for the former, all the objects attached
to the master share the same Finalize_Address primitive whereas, for the
latter, they may have different Finalize_Address primitives.
There is a problem in this scheme with the BIP protocol, because this
protocol forwards the finalization master from callers to callees and it
does so even if the result types are distinct, so it is possible for a
homogeneous finalization master to end up containing objects with different
Finalize_Address primitives; in that case, the object attached last wins
and sets the common Finalize_Address, which is then used to finalize other
objects with unpredictable outcome (and very loud valgrind report).
Therefore, this change gets rid of homogeneous finalization masters and
also streamlines the implementation of heterogeneous ones by storing the
Finalize_Address primitive on a per object basis in the FM_Node record.
gcc/ada/
* einfo.ads (Pending_Access_Types): Delete.
* exp_ch3.adb (Freeze_Type.Process_Pending_Access_Types): Likewise.
(Freeze_Type): Do not call Process_Pending_Access_Types.
* exp_ch7.ads (Make_Set_Finalize_Address_Call): Delete.
* exp_ch7.adb (Build_Finalization_Master.Add_Pending_Access_Type):
Delete.
(Build_Finalization_Master): Do not set Finalize_Address on the
master or call Add_Pending_Access_Type.
(Make_Set_Finalize_Address_Call): Delete.
* gen_il-fields.ads (Opt_Field_Enum): Remove Pending_Access_Types.
* gen_il-gen-gen_entities.adb (Type_Kind): Likewise.
* rtsfind.ads (RE_Id): Remove RE_Set_Finalize_Address.
(RE_Unit_Table): Likewise.
* sem_ch3.adb (Analyze_Full_Type_Declaration): Do not deal with
pending access types.
* libgnat/s-finmas.ads (Attach_Unprotected): Add Finalize_Address
second parameter.
(Delete_Finalize_Address_Unprotected): Delete.
(Finalize_Address): Likewise.
(Finalize_Address_Unprotected): Likewise.
(Is_Homogeneous): Likewise.
(Set_Finalize_Address): Likewise.
(Set_Finalize_Address_Unprotected): Likewise.
(Set_Heterogeneous_Finalize_Address_Unprotected): Likewise.
(Set_Is_Heterogeneous): Likewise.
(FM_Node): Add Finalize_Address component.
(Finalization_Master): Remove Is_Homogeneous and Finalize_Address
components.
* libgnat/s-finmas.adb: Remove with & use clauses for System.HTable.
(Finalize_Address_Table): Delete.
(Attach_Unprotected): Add Finalize_Address second parameter and save
its value in the Finalize_Address field of the node.
(Delete_Finalize_Address_Unprotected): Delete.
(Finalize): Call Finalize_Address saved in the nodes.
(Finalize_Address): Delete.
(Finalize_Address_Unprotected): Likewise.
(Hash): Likewise.
(Is_Homogeneous): Likewise.
(Print_Master): Adjust.
(Set_Finalize_Address): Delete.
(Set_Finalize_Address_Unprotected): Likewise.
(Set_Heterogeneous_Finalize_Address_Unprotected): Likewise.
(Set_Is_Heterogeneous): Likewise.
* libgnat/s-stposu.adb (Finalize_Address_Table_In_Use): Likewise.
(Allocate_Any_Controlled): Pass Fin_Address to Attach_Unprotected
and remove obsolete processing.
(Deallocate_Any_Controlled): Remove obsolete processing.
(Set_Pool_Of_Subpool): Do not call Set_Is_Heterogeneous.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/einfo.ads | 9 --
gcc/ada/exp_ch3.adb | 64 --------
gcc/ada/exp_ch7.adb | 129 ----------------
gcc/ada/exp_ch7.ads | 9 --
gcc/ada/gen_il-fields.ads | 1 -
gcc/ada/gen_il-gen-gen_entities.adb | 1 -
gcc/ada/libgnat/s-finmas.adb | 222 ++++------------------------
gcc/ada/libgnat/s-finmas.ads | 54 +------
gcc/ada/libgnat/s-stposu.adb | 56 +------
gcc/ada/rtsfind.ads | 2 -
gcc/ada/sem_ch3.adb | 8 -
11 files changed, 32 insertions(+), 523 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 3c290ef9a93..c45c124b7ed 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -4008,14 +4008,6 @@ package Einfo is
-- has unknown discriminants. A default initialization of an object of
-- the type does not require an invariant check (AI12-0133).
--- Pending_Access_Types
--- Defined in all types. Set for incomplete, private, Taft-amendment
--- types, and their corresponding full views. This list contains all
--- access types, both named and anonymous, declared between the partial
--- and the full view. The list is used by the finalization machinery to
--- ensure that the finalization masters of all pending access types are
--- fully initialized when the full view is frozen.
-
-- Predicate_Function (synthesized)
-- Defined in all types. Set for types for which (Has_Predicates is True)
-- and for which a predicate procedure has been built that tests that the
@@ -4995,7 +4987,6 @@ package Einfo is
-- Esize
-- RM_Size
-- Alignment
- -- Pending_Access_Types
-- Related_Expression
-- Current_Use_Clause
-- Subprograms_For_Type
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 09551b22154..4c0679f531b 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -9327,10 +9327,6 @@ package body Exp_Ch3 is
-- Validate and generate stubs for all RACW types associated with type
-- Typ.
- procedure Process_Pending_Access_Types (Typ : Entity_Id);
- -- Associate type Typ's Finalize_Address primitive with the finalization
- -- masters of pending access-to-Typ types.
-
------------------------
-- Process_RACW_Types --
------------------------
@@ -9360,61 +9356,6 @@ package body Exp_Ch3 is
end if;
end Process_RACW_Types;
- ----------------------------------
- -- Process_Pending_Access_Types --
- ----------------------------------
-
- procedure Process_Pending_Access_Types (Typ : Entity_Id) is
- E : Elmt_Id;
-
- begin
- -- Finalize_Address is not generated in CodePeer mode because the
- -- body contains address arithmetic. This processing is disabled.
-
- if CodePeer_Mode then
- null;
-
- -- Certain itypes are generated for contexts that cannot allocate
- -- objects and should not set primitive Finalize_Address.
-
- elsif Is_Itype (Typ)
- and then Nkind (Associated_Node_For_Itype (Typ)) =
- N_Explicit_Dereference
- then
- null;
-
- -- When an access type is declared after the incomplete view of a
- -- Taft-amendment type, the access type is considered pending in
- -- case the full view of the Taft-amendment type is controlled. If
- -- this is indeed the case, associate the Finalize_Address routine
- -- of the full view with the finalization masters of all pending
- -- access types. This scenario applies to anonymous access types as
- -- well. But the Finalize_Address routine is missing if the type is
- -- class-wide and we are under restriction No_Dispatching_Calls, see
- -- Expand_Freeze_Class_Wide_Type above for the rationale.
-
- elsif Needs_Finalization (Typ)
- and then (not Is_Class_Wide_Type (Typ)
- or else not Restriction_Active (No_Dispatching_Calls))
- and then Present (Pending_Access_Types (Typ))
- then
- E := First_Elmt (Pending_Access_Types (Typ));
- while Present (E) loop
-
- -- Generate:
- -- Set_Finalize_Address
- -- (Ptr_Typ, <Typ>FD'Unrestricted_Access);
-
- Append_Freeze_Action (Typ,
- Make_Set_Finalize_Address_Call
- (Loc => Sloc (N),
- Ptr_Typ => Node (E)));
-
- Next_Elmt (E);
- end loop;
- end if;
- end Process_Pending_Access_Types;
-
-- Local variables
Def_Id : constant Entity_Id := Entity (N);
@@ -9723,11 +9664,6 @@ package body Exp_Ch3 is
end if;
- -- Complete the initialization of all pending access types' finalization
- -- masters now that the designated type has been is frozen and primitive
- -- Finalize_Address generated.
-
- Process_Pending_Access_Types (Def_Id);
Freeze_Stream_Operations (N, Def_Id);
-- Generate the [spec and] body of the invariant procedure tasked with
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 99142a527fa..e8dfdb02496 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1567,36 +1567,6 @@ package body Exp_Ch7 is
Context_Scope : Entity_Id := Empty;
Insertion_Node : Node_Id := Empty)
is
- procedure Add_Pending_Access_Type
- (Typ : Entity_Id;
- Ptr_Typ : Entity_Id);
- -- Add access type Ptr_Typ to the pending access type list for type Typ
-
- -----------------------------
- -- Add_Pending_Access_Type --
- -----------------------------
-
- procedure Add_Pending_Access_Type
- (Typ : Entity_Id;
- Ptr_Typ : Entity_Id)
- is
- List : Elist_Id;
-
- begin
- if Present (Pending_Access_Types (Typ)) then
- List := Pending_Access_Types (Typ);
- else
- List := New_Elmt_List;
- Set_Pending_Access_Types (Typ, List);
- end if;
-
- Prepend_Elmt (Ptr_Typ, List);
- end Add_Pending_Access_Type;
-
- -- Local variables
-
- Desig_Typ : constant Entity_Id := Designated_Type (Typ);
-
Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
-- A finalization master created for a named access type is associated
-- with the full view (if applicable) as a consequence of freezing. The
@@ -1687,63 +1657,6 @@ package body Exp_Ch7 is
Prefix => New_Occurrence_Of (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
- -- Finalize_Address is not generated in CodePeer mode because the
- -- body contains address arithmetic. Skip this step.
-
- if CodePeer_Mode then
- null;
-
- -- Associate the Finalize_Address primitive of the designated type
- -- with the finalization master of the access type. The designated
- -- type must be frozen, as Finalize_Address is generated when the
- -- freeze node is expanded.
-
- elsif Is_Frozen (Desig_Typ)
- and then Present (Finalize_Address (Desig_Typ))
-
- -- The Finalize_Address procedure for a class-wide type may exist
- -- at this point (as created by Expand_Freeze_Record_Type), but
- -- may not have been analyzed yet, so the Set_Finalize_Address call
- -- generation must be deferred (to Freeze_Type) in that case.
-
- and then Analyzed (Finalize_Address (Desig_Typ))
-
- -- The finalization master of an anonymous access type may need
- -- to be inserted in a specific place in the tree. For instance:
-
- -- type Comp_Typ;
-
- -- <finalization master of "access Comp_Typ">
-
- -- type Rec_Typ is record
- -- Comp : access Comp_Typ;
- -- end record;
-
- -- <freeze node for Comp_Typ>
- -- <freeze node for Rec_Typ>
-
- -- Due to this oddity, the anonymous access type is stored for
- -- later processing (see below).
-
- and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
- then
- -- Generate:
- -- Set_Finalize_Address
- -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
-
- Append_To (Actions,
- Make_Set_Finalize_Address_Call
- (Loc => Loc,
- Ptr_Typ => Ptr_Typ));
-
- -- Otherwise the designated type is either anonymous access or a
- -- Taft-amendment type and has not been frozen. Store the access
- -- type for later processing (see Freeze_Type).
-
- else
- Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
- end if;
-
-- A finalization master created for an access designating a type
-- with private components is inserted before a context-dependent
-- node.
@@ -8753,48 +8666,6 @@ package body Exp_Ch7 is
New_Occurrence_Of (RTE (RE_Master_Node), Loc));
end Make_Master_Node_Declaration;
- ------------------------------------
- -- Make_Set_Finalize_Address_Call --
- ------------------------------------
-
- function Make_Set_Finalize_Address_Call
- (Loc : Source_Ptr;
- Ptr_Typ : Entity_Id) return Node_Id
- is
- -- It is possible for Ptr_Typ to be a partial view, if the access type
- -- is a full view declared in the private part of a nested package, and
- -- the finalization actions take place when completing analysis of the
- -- enclosing unit. For this reason use Underlying_Type twice below.
-
- Desig_Typ : constant Entity_Id :=
- Available_View
- (Designated_Type (Underlying_Type (Ptr_Typ)));
- Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
- Fin_Mas : constant Entity_Id :=
- Finalization_Master (Underlying_Type (Ptr_Typ));
-
- begin
- -- Both the finalization master and primitive Finalize_Address must be
- -- available.
-
- pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
-
- -- Generate:
- -- Set_Finalize_Address
- -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
-
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas, Loc),
-
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Fin_Addr, Loc),
- Attribute_Name => Name_Unrestricted_Access)));
- end Make_Set_Finalize_Address_Call;
-
----------------------------------------
-- Make_Suppress_Object_Finalize_Call --
----------------------------------------
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 97fea23b4ac..9a4797d0766 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -244,15 +244,6 @@ package Exp_Ch7 is
Obj : Entity_Id) return Node_Id;
-- Build the declaration of the Master_Node for the object Obj
- function Make_Set_Finalize_Address_Call
- (Loc : Source_Ptr;
- Ptr_Typ : Entity_Id) return Node_Id;
- -- Associate the Finalize_Address primitive of the designated type with the
- -- finalization master of access type Ptr_Typ. The returned call is:
- --
- -- Set_Finalize_Address
- -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
-
function Make_Suppress_Object_Finalize_Call
(Loc : Source_Ptr;
Obj : Entity_Id) return Node_Id;
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 0a5bddf5816..f53b565309a 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -850,7 +850,6 @@ package Gen_IL.Fields is
Part_Of_Constituents,
Part_Of_References,
Partial_View_Has_Unknown_Discr,
- Pending_Access_Types,
Predicate_Expression,
Prev_Entity,
Prival,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index dd5db9746fd..50bcec8514c 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -520,7 +520,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Optimize_Alignment_Space, Flag),
Sm (Optimize_Alignment_Time, Flag),
Sm (Partial_View_Has_Unknown_Discr, Flag),
- Sm (Pending_Access_Types, Elist_Id),
Sm (Related_Expression, Node_Id),
Sm (RM_Size, Uint),
Sm (SPARK_Pragma, Node_Id),
diff --git a/gcc/ada/libgnat/s-finmas.adb b/gcc/ada/libgnat/s-finmas.adb
index 64b6344fe20..edf0242e954 100644
--- a/gcc/ada/libgnat/s-finmas.adb
+++ b/gcc/ada/libgnat/s-finmas.adb
@@ -32,32 +32,12 @@
with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
-with System.HTable; use System.HTable;
with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Finalization_Masters is
- -- Finalize_Address hash table types. In general, masters are homogeneous
- -- collections of controlled objects. Rare cases such as allocations on a
- -- subpool require heterogeneous masters. The following table provides a
- -- relation between object address and its Finalize_Address routine.
-
- type Header_Num is range 0 .. 127;
-
- function Hash (Key : System.Address) return Header_Num;
-
- -- Address --> Finalize_Address_Ptr
-
- package Finalize_Address_Table is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Finalize_Address_Ptr,
- No_Element => null,
- Key => System.Address,
- Hash => Hash,
- Equal => "=");
-
---------------------------
-- Add_Offset_To_Address --
---------------------------
@@ -75,14 +55,17 @@ package body System.Finalization_Masters is
------------------------
procedure Attach_Unprotected
- (N : not null FM_Node_Ptr;
- L : not null FM_Node_Ptr)
+ (N : not null FM_Node_Ptr;
+ Finalize_Address : not null Finalize_Address_Ptr;
+ L : not null FM_Node_Ptr)
is
begin
+ N.Finalize_Address := Finalize_Address;
+ N.Prev := L;
+ N.Next := L.Next;
+
L.Next.Prev := N;
- N.Next := L.Next;
- L.Next := N;
- N.Prev := L;
+ L.Next := N;
end Attach_Unprotected;
---------------
@@ -96,15 +79,6 @@ package body System.Finalization_Masters is
return Master.Base_Pool;
end Base_Pool;
- -----------------------------------------
- -- Delete_Finalize_Address_Unprotected --
- -----------------------------------------
-
- procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
- begin
- Finalize_Address_Table.Remove (Obj);
- end Delete_Finalize_Address_Unprotected;
-
------------------------
-- Detach_Unprotected --
------------------------
@@ -124,7 +98,6 @@ package body System.Finalization_Masters is
--------------
overriding procedure Finalize (Master : in out Finalization_Master) is
- Cleanup : Finalize_Address_Ptr;
Curr_Ptr : FM_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Obj_Addr : Address;
@@ -186,31 +159,8 @@ package body System.Finalization_Masters is
Obj_Addr := Curr_Ptr.all'Address + Header_Size;
- -- Retrieve TSS primitive Finalize_Address depending on the master's
- -- mode of operation.
-
- -- Synchronization:
- -- Read - allocation, finalization
- -- Write - outside
-
- if Master.Is_Homogeneous then
-
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, outside
-
- Cleanup := Master.Finalize_Address;
-
- else
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation
-
- Cleanup := Finalize_Address_Unprotected (Obj_Addr);
- end if;
-
begin
- Cleanup (Obj_Addr);
+ Curr_Ptr.Finalize_Address (Obj_Addr);
exception
when Fin_Occur : others =>
if not Raised then
@@ -218,22 +168,6 @@ package body System.Finalization_Masters is
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
-
- -- When the master is a heterogeneous collection, destroy the object
- -- - Finalize_Address pair since it is no longer needed.
-
- -- Synchronization:
- -- Read - finalization
- -- Write - outside
-
- if not Master.Is_Homogeneous then
-
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation, finalization
-
- Delete_Finalize_Address_Unprotected (Obj_Addr);
- end if;
end loop;
Unlock_Task.all;
@@ -246,28 +180,6 @@ package body System.Finalization_Masters is
end if;
end Finalize;
- ----------------------
- -- Finalize_Address --
- ----------------------
-
- function Finalize_Address
- (Master : Finalization_Master) return Finalize_Address_Ptr
- is
- begin
- return Master.Finalize_Address;
- end Finalize_Address;
-
- ----------------------------------
- -- Finalize_Address_Unprotected --
- ----------------------------------
-
- function Finalize_Address_Unprotected
- (Obj : System.Address) return Finalize_Address_Ptr
- is
- begin
- return Finalize_Address_Table.Get (Obj);
- end Finalize_Address_Unprotected;
-
--------------------------
-- Finalization_Started --
--------------------------
@@ -279,17 +191,6 @@ package body System.Finalization_Masters is
return Master.Finalization_Started;
end Finalization_Started;
- ----------
- -- Hash --
- ----------
-
- function Hash (Key : System.Address) return Header_Num is
- begin
- return
- Header_Num
- (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
- end Hash;
-
-----------------
-- Header_Size --
-----------------
@@ -311,15 +212,6 @@ package body System.Finalization_Masters is
Master.Objects.Prev := Master.Objects'Unchecked_Access;
end Initialize;
- --------------------
- -- Is_Homogeneous --
- --------------------
-
- function Is_Homogeneous (Master : Finalization_Master) return Boolean is
- begin
- return Master.Is_Homogeneous;
- end Is_Homogeneous;
-
-------------
-- Objects --
-------------
@@ -342,17 +234,12 @@ package body System.Finalization_Masters is
-- Output the basic contents of a master
-- Master : 0x123456789
- -- Is_Hmgen : TURE <or> FALSE
-- Base_Pool: null <or> 0x123456789
- -- Fin_Addr : null <or> 0x123456789
-- Fin_Start: TRUE <or> FALSE
Put ("Master : ");
Put_Line (Address_Image (Master'Address));
- Put ("Is_Hmgen : ");
- Put_Line (Master.Is_Homogeneous'Img);
-
Put ("Base_Pool: ");
if Master.Base_Pool = null then
Put_Line ("null");
@@ -360,13 +247,6 @@ package body System.Finalization_Masters is
Put_Line (Address_Image (Master.Base_Pool'Address));
end if;
- Put ("Fin_Addr : ");
- if Master.Finalize_Address = null then
- Put_Line ("null");
- else
- Put_Line (Address_Image (Master.Finalize_Address'Address));
- end if;
-
Put ("Fin_Start: ");
Put_Line (Master.Finalization_Started'Img);
@@ -374,8 +254,9 @@ package body System.Finalization_Masters is
-- ^ <or> ? <or> null
-- |Header: 0x123456789 (dummy head)
- -- | Prev: 0x123456789
- -- | Next: 0x123456789
+ -- | Fin_Addr: 0x0001F2580
+ -- | Prev : 0x123456789
+ -- | Next : 0x123456789
-- V
-- ^ - the current element points back to the correct element
@@ -383,10 +264,11 @@ package body System.Finalization_Masters is
-- 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
+ -- Fin_Addr - the Finalize_Address routine
+ -- 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;
@@ -432,7 +314,14 @@ package body System.Finalization_Masters is
Put_Line ("");
end if;
- Put ("| Prev: ");
+ Put ("| Fin_Addr: ");
+ if N_Ptr.Finalize_Address = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (N_Ptr.Finalize_Address'Address));
+ end if;
+
+ Put ("| Prev : ");
if N_Ptr.Prev = null then
Put_Line ("null");
@@ -440,7 +329,7 @@ package body System.Finalization_Masters is
Put_Line (Address_Image (N_Ptr.Prev.all'Address));
end if;
- Put ("| Next: ");
+ Put ("| Next : ");
if N_Ptr.Next = null then
Put_Line ("null");
@@ -464,63 +353,4 @@ package body System.Finalization_Masters is
Master.Base_Pool := Pool_Ptr;
end Set_Base_Pool;
- --------------------------
- -- Set_Finalize_Address --
- --------------------------
-
- procedure Set_Finalize_Address
- (Master : in out Finalization_Master;
- Fin_Addr_Ptr : Finalize_Address_Ptr)
- is
- begin
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, outside
-
- Lock_Task.all;
- Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
- Unlock_Task.all;
- end Set_Finalize_Address;
-
- --------------------------------------
- -- Set_Finalize_Address_Unprotected --
- --------------------------------------
-
- procedure Set_Finalize_Address_Unprotected
- (Master : in out Finalization_Master;
- Fin_Addr_Ptr : Finalize_Address_Ptr)
- is
- begin
- if Master.Finalize_Address = null then
- Master.Finalize_Address := Fin_Addr_Ptr;
- end if;
- end Set_Finalize_Address_Unprotected;
-
- ----------------------------------------------------
- -- Set_Heterogeneous_Finalize_Address_Unprotected --
- ----------------------------------------------------
-
- procedure Set_Heterogeneous_Finalize_Address_Unprotected
- (Obj : System.Address;
- Fin_Addr_Ptr : Finalize_Address_Ptr)
- is
- begin
- Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
- end Set_Heterogeneous_Finalize_Address_Unprotected;
-
- --------------------------
- -- Set_Is_Heterogeneous --
- --------------------------
-
- procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
- begin
- -- Synchronization:
- -- Read - finalization
- -- Write - outside
-
- Lock_Task.all;
- Master.Is_Homogeneous := False;
- Unlock_Task.all;
- end Set_Is_Heterogeneous;
-
end System.Finalization_Masters;
diff --git a/gcc/ada/libgnat/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads
index 7385a3a1b7d..d1edda9de66 100644
--- a/gcc/ada/libgnat/s-finmas.ads
+++ b/gcc/ada/libgnat/s-finmas.ads
@@ -72,14 +72,11 @@ package System.Finalization_Masters is
for Finalization_Master_Ptr'Storage_Size use 0;
procedure Attach_Unprotected
- (N : not null FM_Node_Ptr;
- L : not null FM_Node_Ptr);
+ (N : not null FM_Node_Ptr;
+ Finalize_Address : not null Finalize_Address_Ptr;
+ L : not null FM_Node_Ptr);
-- Prepend a node to a specific finalization master
- procedure Delete_Finalize_Address_Unprotected (Obj : System.Address);
- -- Destroy the relation pair object - Finalize_Address from the internal
- -- hash table.
-
procedure Detach_Unprotected (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
@@ -88,57 +85,24 @@ package System.Finalization_Masters is
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
- function Finalize_Address
- (Master : Finalization_Master) return Finalize_Address_Ptr;
- -- Return a reference to the TSS primitive Finalize_Address associated with
- -- a master.
-
- function Finalize_Address_Unprotected
- (Obj : System.Address) return Finalize_Address_Ptr;
- -- Retrieve the Finalize_Address primitive associated with a particular
- -- object.
-
function Finalization_Started (Master : Finalization_Master) return Boolean;
-- Return the finalization status of a master
function Header_Size return System.Storage_Elements.Storage_Count;
-- Return the size of type FM_Node as Storage_Count
- function Is_Homogeneous (Master : Finalization_Master) return Boolean;
- -- Return the behavior flag of a master
-
function Objects (Master : Finalization_Master) return FM_Node_Ptr;
-- Return the header of the doubly-linked list of controlled objects
procedure Print_Master (Master : Finalization_Master);
-- Debug routine, outputs the contents of a master
- procedure Set_Finalize_Address
- (Master : in out Finalization_Master;
- Fin_Addr_Ptr : Finalize_Address_Ptr);
- -- Compiler interface, do not call from within the run-time. Set the clean
- -- up routine of a finalization master
-
- procedure Set_Finalize_Address_Unprotected
- (Master : in out Finalization_Master;
- Fin_Addr_Ptr : Finalize_Address_Ptr);
- -- Set the clean up routine of a finalization master
-
- procedure Set_Heterogeneous_Finalize_Address_Unprotected
- (Obj : System.Address;
- Fin_Addr_Ptr : Finalize_Address_Ptr);
- -- Add a relation pair object - Finalize_Address to the internal hash
- -- table. This is done in the context of allocation on a heterogeneous
- -- finalization master where a single master services multiple anonymous
- -- access-to-controlled types.
-
- procedure Set_Is_Heterogeneous (Master : in out Finalization_Master);
- -- Mark the master as being a heterogeneous collection of objects
-
private
-- Heterogeneous collection type structure
type FM_Node is record
+ Finalize_Address : Finalize_Address_Ptr := null;
+
Prev : FM_Node_Ptr := null;
Next : FM_Node_Ptr := null;
end record;
@@ -151,10 +115,6 @@ private
type Finalization_Master is
new Ada.Finalization.Limited_Controlled with
record
- Is_Homogeneous : Boolean := True;
- -- A flag which controls the behavior of the master. A value of False
- -- denotes a heterogeneous collection.
-
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.
@@ -163,10 +123,6 @@ private
-- A doubly linked list which contains the headers of all controlled
-- objects allocated in a [sub]pool.
- Finalize_Address : Finalize_Address_Ptr := null;
- -- A reference to the routine reponsible for object finalization. This
- -- is used only when the master is in homogeneous mode.
-
Finalization_Started : Boolean := False;
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb
index 7ed30b8563d..7bd90cc7143 100644
--- a/gcc/ada/libgnat/s-stposu.adb
+++ b/gcc/ada/libgnat/s-stposu.adb
@@ -43,11 +43,6 @@ use System.Storage_Pools.Subpools.Finalization;
package body System.Storage_Pools.Subpools is
- Finalize_Address_Table_In_Use : Boolean := False;
- -- This flag should be set only when a successful allocation on a subpool
- -- has been performed and the associated Finalize_Address has been added to
- -- the hash table in System.Finalization_Masters.
-
function Address_To_FM_Node_Ptr is
new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);
@@ -284,45 +279,13 @@ package body System.Storage_Pools.Subpools is
-- Synchronization:
-- Write - allocation, deallocation, finalization
- Attach_Unprotected (N_Ptr, Objects (Master.all));
+ Attach_Unprotected (N_Ptr, Fin_Address, Objects (Master.all));
-- 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_And_Padding;
- -- Homogeneous masters service the following:
-
- -- 1) Allocations on / Deallocations from regular pools
- -- 2) Named access types
- -- 3) Most cases of anonymous access types usage
-
- -- Synchronization:
- -- Read - allocation, finalization
- -- Write - outside
-
- if Master.Is_Homogeneous then
-
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, outside
-
- Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
-
- -- Heterogeneous masters service the following:
-
- -- 1) Allocations on / Deallocations from subpools
- -- 2) Certain cases of anonymous access types usage
-
- else
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation
-
- Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
- Finalize_Address_Table_In_Use := True;
- end if;
-
Unlock_Task.all;
Lock_Taken := False;
@@ -394,18 +357,6 @@ package body System.Storage_Pools.Subpools is
Lock_Task.all;
begin
- -- Destroy the relation pair object - Finalize_Address since it is
- -- no longer needed.
-
- if Finalize_Address_Table_In_Use then
-
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation
-
- Delete_Finalize_Address_Unprotected (Addr);
- end if;
-
-- Account for possible padding space before the header due to a
-- larger alignment.
@@ -821,11 +772,6 @@ package body System.Storage_Pools.Subpools is
Subpool.Node := N_Ptr;
Attach (N_Ptr, To.Subpools'Unchecked_Access);
-
- -- Mark the subpool's master as being a heterogeneous collection of
- -- controlled objects.
-
- Set_Is_Heterogeneous (Subpool.Master);
end Set_Pool_Of_Subpool;
end System.Storage_Pools.Subpools;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index dc06bffa509..0b88409795a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -923,7 +923,6 @@ package Rtsfind is
RE_Finalization_Master, -- System.Finalization_Masters
RE_Finalization_Master_Ptr, -- System.Finalization_Masters
RE_Set_Base_Pool, -- System.Finalization_Masters
- RE_Set_Finalize_Address, -- System.Finalization_Masters
RE_Attach_Object_To_Master, -- System.Finalization_Primitives
RE_Attach_Object_To_Node, -- System.Finalization_Primitives
@@ -2576,7 +2575,6 @@ package Rtsfind is
RE_Finalization_Master => System_Finalization_Masters,
RE_Finalization_Master_Ptr => System_Finalization_Masters,
RE_Set_Base_Pool => System_Finalization_Masters,
- RE_Set_Finalize_Address => System_Finalization_Masters,
RE_Attach_Object_To_Master => System_Finalization_Primitives,
RE_Attach_Object_To_Node => System_Finalization_Primitives,
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index c15f0bfc283..737ea809492 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3479,14 +3479,6 @@ package body Sem_Ch3 is
Generate_Definition (Def_Id);
end if;
- -- Propagate any pending access types whose finalization masters need to
- -- be fully initialized from the partial to the full view. Guard against
- -- an illegal full view that remains unanalyzed.
-
- if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then
- Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev));
- end if;
-
if Chars (Scope (Def_Id)) = Name_System
and then Chars (Def_Id) = Name_Address
and then In_Predefined_Unit (N)
--
2.43.2
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2024-05-07 8:00 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2024-05-07 8:00 [COMMITTED] ada: Fix bad interaction between homogeneous finalization master and BIP protocol Marc Poulhiès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).