public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-400] [Ada] Implement late initialization rules for type extensions
@ 2022-05-13 8:08 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-13 8:08 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:b77029ff250b7a6b0a8f07aa0c4199adca2f4e91
commit r13-400-gb77029ff250b7a6b0a8f07aa0c4199adca2f4e91
Author: Steve Baird <baird@adacore.com>
Date: Tue Feb 8 17:43:14 2022 -0800
[Ada] Implement late initialization rules for type extensions
Default initialization of a record object is required to initialize any
components that "require late initialization" after other components.
This includes the case of a type extension; "late initialization"
components of the parent type are required to be initialized after
non-late-init extension components. This is implemented by generalizing
the use of an existing init proc parameter. Previously, the init proc
for a tagged type took a Boolean parameter indicating whether or not to
initialize the Tag component. With this change, this parameter can now
take on any of four values indicating whether to perform
1) Full initialization (including the tag component).
2) Full initialization except for the tag component.
3) Early (non-tag) initialization only.
4) Late (non-tag) initialization only.
With this change, the init proc for a type extension has the option of
performing the early and late portions of the parent's initialization
via two separate calls to the parent type's init proc.
gcc/ada/
* exp_ch3.ads (Build_Intialization_Call): Add new formal
parameter, Init_Control_Actual, with default value. Clients
outside of package Exp_Ch3 are unaffected.
* exp_ch3.adb (Initialization_Control): new package; support for
this 4-valued parameter. The existing Requires_Late_Init
function is moved into this new package.
(Build_Initialization_Call): Add new formal parameter for
subprogram body, use this new formal parameter in generating an
init proc call.
(Build_Record_Init_Proc): Replace Set_Tag Boolean formal
parameter with 4-valued Init_Control_Formal. Wrap if-statements
with appropriate conditions around tag initialization, early
initialization, and late initialization statements.
* exp_util.adb (Build_Task_Image_Decl): Avoid problem with
duplicate declarations when an init proc for a type extension
calls the parent type's init proc twice.
Diff:
---
gcc/ada/exp_ch3.adb | 741 +++++++++++++++++++++++++++++++++++----------------
gcc/ada/exp_ch3.ads | 23 +-
gcc/ada/exp_util.adb | 9 +-
3 files changed, 529 insertions(+), 244 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index c5ed4689ffc..d1b33883af1 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -184,6 +184,63 @@ package body Exp_Ch3 is
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
+ package Initialization_Control is
+
+ function Requires_Late_Init
+ (Decl : Node_Id; Rec_Type : Entity_Id) return Boolean;
+ -- Return True iff the given component declaration requires late
+ -- initialization, as defined by 3.3.1 (8.1/5).
+
+ function Has_Late_Init_Component
+ (Tagged_Rec_Type : Entity_Id) return Boolean;
+ -- Return True iff the given tagged record type has at least one
+ -- component that requires late initialization; this includes
+ -- components of ancestor types.
+
+ type Initialization_Mode is
+ (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
+ -- The initialization routine for a tagged type is passed in a
+ -- formal parameter of this type, indicating what initialization
+ -- is to be performed. This parameter defaults to Full_Init in all
+ -- cases except when the init proc of a type extension (let's call
+ -- that type T2) calls the init proc of its parent (let's call that
+ -- type T1). In that case, one of the other 3 values will
+ -- be passed in. In all three of those cases, the Tag component has
+ -- already been initialized before the call and is therefore not to be
+ -- modified. T2's init proc will either call T1's init proc
+ -- once (with Full_Init_Except_Tag as the parameter value) or twice
+ -- (first with Early_Init_Only, then later with Late_Init_Only),
+ -- depending on the result returned by Has_Late_Init_Component (T1).
+ -- In the latter case, the first call does not initialize any
+ -- components that require late initialization and the second call
+ -- then performs that deferred initialization.
+ -- Strictly speaking, the formal parameter subtype is actually Natural
+ -- but calls will only pass in values corresponding to literals
+ -- of this enumeration type.
+
+ function Make_Mode_Literal
+ (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
+ is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
+ -- Generate an integer literal for a given mode value.
+
+ function Tag_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id;
+ function Early_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id;
+ function Late_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id;
+ -- These three functions each return a Boolean expression that
+ -- can be used to determine whether a given call to the initialization
+ -- expression for a tagged type should initialize (respectively)
+ -- the Tag component, the non-Tag components that do not require late
+ -- initialization, and the components that do require late
+ -- initialization.
+
+ end Initialization_Control;
+
procedure Initialization_Warning (E : Entity_Id);
-- If static elaboration of the package is requested, indicate
-- when a type does meet the conditions for static initialization. If
@@ -1447,14 +1504,15 @@ package body Exp_Ch3 is
-- end;
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False;
- Constructor_Ref : Node_Id := Empty) return List_Id
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty;
+ Init_Control_Actual : Entity_Id := Empty) return List_Id
is
Res : constant List_Id := New_List;
@@ -1838,14 +1896,26 @@ package body Exp_Ch3 is
-- If this is a call to initialize the parent component of a derived
-- tagged type, indicate that the tag should not be set in the parent.
+ -- This is done via the actual parameter value for the Init_Control
+ -- formal parameter, which is also used to deal with late initialization
+ -- requirements.
+ --
+ -- We pass in Full_Init_Except_Tag unless the caller tells us to do
+ -- otherwise (by passing in a nonempty Init_Control_Actual parameter).
if Is_Tagged_Type (Full_Init_Type)
and then not Is_CPP_Class (Full_Init_Type)
and then Nkind (Id_Ref) = N_Selected_Component
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
- Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
-
+ declare
+ use Initialization_Control;
+ begin
+ Append_To (Args,
+ (if Present (Init_Control_Actual)
+ then Init_Control_Actual
+ else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
+ end;
elsif Present (Constructor_Ref) then
Append_List_To (Args,
New_Copy_List (Parameter_Associations (Constructor_Ref)));
@@ -1906,8 +1976,9 @@ package body Exp_Ch3 is
Counter : Nat := 0;
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
- Set_Tag : Entity_Id := Empty;
- Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
+
+ Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements
+ Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
function Build_Assignment
(Id : Entity_Id;
@@ -2532,6 +2603,7 @@ package body Exp_Ch3 is
Proc_Spec_Node : Node_Id;
Record_Extension_Node : Node_Id;
+ use Initialization_Control;
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
@@ -2544,21 +2616,27 @@ package body Exp_Ch3 is
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
- -- For tagged types, we add a flag to indicate whether the routine
- -- is called to initialize a parent component in the init_proc of
- -- a type extension. If the flag is false, we do not set the tag
- -- because it has been set already in the extension.
+ -- For tagged types, we add a parameter to indicate what
+ -- portion of the object's initialization is to be performed.
+ -- This is used for two purposes:
+ -- 1) When a type extension's initialization procedure calls
+ -- the initialization procedure of the parent type, we do
+ -- not want the parent to initialize the Tag component;
+ -- it has been set already.
+ -- 2) If an ancestor type has at least one component that requires
+ -- late initialization, then we need to be able to initialize
+ -- those components separately after initializing any other
+ -- components.
if Is_Tagged_Type (Rec_Type) then
- Set_Tag := Make_Temporary (Loc, 'P');
+ Init_Control_Formal := Make_Temporary (Loc, 'P');
Append_To (Parameters,
Make_Parameter_Specification (Loc,
- Defining_Identifier => Set_Tag,
+ Defining_Identifier => Init_Control_Formal,
Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression =>
- New_Occurrence_Of (Standard_True, Loc)));
+ New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Mode_Literal (Loc, Full_Init)));
end if;
-- Create an extra accessibility parameter to capture the level of
@@ -2622,22 +2700,45 @@ package body Exp_Ch3 is
declare
Parent_IP : constant Name_Id :=
Make_Init_Proc_Name (Etype (Rec_Ent));
- Stmt : Node_Id;
- IP_Call : Node_Id;
- IP_Stmts : List_Id;
-
+ Stmt : Node_Id := First (Stmts);
+ IP_Call : Node_Id := Empty;
begin
- -- Look for a call to the parent IP at the beginning
- -- of Stmts associated with the record extension
+ -- Look for a call to the parent IP associated with
+ -- the record extension.
+ -- The call will be inside not one but two
+ -- if-statements (with the same condition). Testing
+ -- the same Early_Init condition twice might seem
+ -- redundant. However, as soon as we exit this loop,
+ -- we are going to hoist the inner if-statement out
+ -- of the outer one; the "redundant" test was built
+ -- in anticipation of this hoisting.
- Stmt := First (Stmts);
- IP_Call := Empty;
while Present (Stmt) loop
- if Nkind (Stmt) = N_Procedure_Call_Statement
- and then Chars (Name (Stmt)) = Parent_IP
- then
- IP_Call := Stmt;
- exit;
+ if Nkind (Stmt) = N_If_Statement then
+ declare
+ Then_Stmt1 : Node_Id :=
+ First (Then_Statements (Stmt));
+ Then_Stmt2 : Node_Id;
+ begin
+ while Present (Then_Stmt1) loop
+ if Nkind (Then_Stmt1) = N_If_Statement then
+ Then_Stmt2 :=
+ First (Then_Statements (Then_Stmt1));
+
+ if Nkind (Then_Stmt2) =
+ N_Procedure_Call_Statement
+ and then Chars (Name (Then_Stmt2)) =
+ Parent_IP
+ then
+ -- IP_Call is a call wrapped in an
+ -- if statement.
+ IP_Call := Then_Stmt1;
+ exit;
+ end if;
+ end if;
+ Next (Then_Stmt1);
+ end loop;
+ end;
end if;
Next (Stmt);
@@ -2647,14 +2748,8 @@ package body Exp_Ch3 is
-- statements of this IP routine
if Present (IP_Call) then
- IP_Stmts := New_List;
- loop
- Stmt := Remove_Head (Stmts);
- Append_To (IP_Stmts, Stmt);
- exit when Stmt = IP_Call;
- end loop;
-
- Prepend_List_To (Body_Stmts, IP_Stmts);
+ Remove (IP_Call);
+ Prepend_List_To (Body_Stmts, New_List (IP_Call));
end if;
end;
end if;
@@ -2729,7 +2824,8 @@ package body Exp_Ch3 is
Elab_List := New_List (
Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Condition =>
+ Tag_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Init_Tags_List));
if Elab_Flag_Needed (Rec_Type) then
@@ -2755,7 +2851,8 @@ package body Exp_Ch3 is
else
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Condition =>
+ Tag_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Init_Tags_List));
end if;
@@ -2823,11 +2920,18 @@ package body Exp_Ch3 is
begin
-- Search for the call to the IP of the parent. We assume
-- that the first init_proc call is for the parent.
+ -- It is wrapped in an "if Early_Init_Condition"
+ -- if-statement.
Ins_Nod := First (Body_Stmts);
while Present (Next (Ins_Nod))
- and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
- or else not Is_Init_Proc (Name (Ins_Nod)))
+ and then
+ (Nkind (Ins_Nod) /= N_If_Statement
+ or else (Nkind (First (Then_Statements (Ins_Nod)))
+ /= N_Procedure_Call_Statement)
+ or else not Is_Init_Proc
+ (Name (First (Then_Statements
+ (Ins_Nod)))))
loop
Next (Ins_Nod);
end loop;
@@ -2974,34 +3078,31 @@ package body Exp_Ch3 is
Decl : Node_Id;
Id : Entity_Id;
Parent_Stmts : List_Id;
- Stmts : List_Id;
+ Parent_Id : Entity_Id := Empty;
+ Stmts, Late_Stmts : List_Id := Empty_List;
Typ : Entity_Id;
- procedure Increment_Counter (Loc : Source_Ptr);
+ procedure Increment_Counter
+ (Loc : Source_Ptr; Late : Boolean := False);
-- Generate an "increment by one" statement for the current counter
- -- and append it to the list Stmts.
+ -- and append it to the appropriate statement list.
procedure Make_Counter (Loc : Source_Ptr);
-- Create a new counter for the current component list. The routine
-- creates a new defining Id, adds an object declaration and sets
-- the Id generator for the next variant.
- function Requires_Late_Initialization
- (Decl : Node_Id;
- Rec_Type : Entity_Id) return Boolean;
- -- Return whether the given Decl requires late initialization, as
- -- defined by 3.3.1 (8.1/5).
-
-----------------------
-- Increment_Counter --
-----------------------
- procedure Increment_Counter (Loc : Source_Ptr) is
+ procedure Increment_Counter
+ (Loc : Source_Ptr; Late : Boolean := False) is
begin
-- Generate:
-- Counter := Counter + 1;
- Append_To (Stmts,
+ Append_To ((if Late then Late_Stmts else Stmts),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Counter_Id, Loc),
Expression =>
@@ -3038,157 +3139,6 @@ package body Exp_Ch3 is
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
- ----------------------------------
- -- Requires_Late_Initialization --
- ----------------------------------
-
- function Requires_Late_Initialization
- (Decl : Node_Id;
- Rec_Type : Entity_Id) return Boolean
- is
- References_Current_Instance : Boolean := False;
- Has_Access_Discriminant : Boolean := False;
- Has_Internal_Call : Boolean := False;
-
- function Find_Access_Discriminant
- (N : Node_Id) return Traverse_Result;
- -- Look for a name denoting an access discriminant
-
- function Find_Current_Instance
- (N : Node_Id) return Traverse_Result;
- -- Look for a reference to the current instance of the type
-
- function Find_Internal_Call
- (N : Node_Id) return Traverse_Result;
- -- Look for an internal protected function call
-
- ------------------------------
- -- Find_Access_Discriminant --
- ------------------------------
-
- function Find_Access_Discriminant
- (N : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (N)
- and then Denotes_Discriminant (N)
- and then Is_Access_Type (Etype (N))
- then
- Has_Access_Discriminant := True;
- return Abandon;
- else
- return OK;
- end if;
- end Find_Access_Discriminant;
-
- ---------------------------
- -- Find_Current_Instance --
- ---------------------------
-
- function Find_Current_Instance
- (N : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Current_Instance (N)
- then
- References_Current_Instance := True;
- return Abandon;
- else
- return OK;
- end if;
- end Find_Current_Instance;
-
- ------------------------
- -- Find_Internal_Call --
- ------------------------
-
- function Find_Internal_Call (N : Node_Id) return Traverse_Result is
-
- function Call_Scope (N : Node_Id) return Entity_Id;
- -- Return the scope enclosing a given call node N
-
- ----------------
- -- Call_Scope --
- ----------------
-
- function Call_Scope (N : Node_Id) return Entity_Id is
- Nam : constant Node_Id := Name (N);
- begin
- if Nkind (Nam) = N_Selected_Component then
- return Scope (Entity (Prefix (Nam)));
- else
- return Scope (Entity (Nam));
- end if;
- end Call_Scope;
-
- begin
- if Nkind (N) = N_Function_Call
- and then Call_Scope (N)
- = Corresponding_Concurrent_Type (Rec_Type)
- then
- Has_Internal_Call := True;
- return Abandon;
- else
- return OK;
- end if;
- end Find_Internal_Call;
-
- procedure Search_Access_Discriminant is new
- Traverse_Proc (Find_Access_Discriminant);
-
- procedure Search_Current_Instance is new
- Traverse_Proc (Find_Current_Instance);
-
- procedure Search_Internal_Call is new
- Traverse_Proc (Find_Internal_Call);
-
- begin
- -- A component of an object is said to require late initialization
- -- if:
-
- -- it has an access discriminant value constrained by a per-object
- -- expression;
-
- if Has_Access_Constraint (Defining_Identifier (Decl))
- and then No (Expression (Decl))
- then
- return True;
-
- elsif Present (Expression (Decl)) then
-
- -- it has an initialization expression that includes a name
- -- denoting an access discriminant;
-
- Search_Access_Discriminant (Expression (Decl));
-
- if Has_Access_Discriminant then
- return True;
- end if;
-
- -- or it has an initialization expression that includes a
- -- reference to the current instance of the type either by
- -- name...
-
- Search_Current_Instance (Expression (Decl));
-
- if References_Current_Instance then
- return True;
- end if;
-
- -- ...or implicitly as the target object of a call.
-
- if Is_Protected_Record_Type (Rec_Type) then
- Search_Internal_Call (Expression (Decl));
-
- if Has_Internal_Call then
- return True;
- end if;
- end if;
- end if;
-
- return False;
- end Requires_Late_Initialization;
-
-- Start of processing for Build_Init_Statements
begin
@@ -3256,7 +3206,10 @@ package body Exp_Ch3 is
-- Leave any processing of component requiring late initialization
-- for the second pass.
- if Requires_Late_Initialization (Decl, Rec_Type) then
+ if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then
+ if not Has_Late_Init_Comp then
+ Late_Stmts := New_List;
+ end if;
Has_Late_Init_Comp := True;
-- Regular component cases
@@ -3403,17 +3356,56 @@ package body Exp_Ch3 is
elsif not Is_Interface (Typ)
and then Has_Non_Null_Base_Init_Proc (Typ)
then
- Actions :=
- Build_Initialization_Call
- (Comp_Loc,
- Make_Selected_Component (Comp_Loc,
- Prefix =>
- Make_Identifier (Comp_Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
- Typ,
- In_Init_Proc => True,
- Enclos_Type => Rec_Type,
- Discr_Map => Discr_Map);
+ declare
+ use Initialization_Control;
+ Init_Control_Actual : Node_Id := Empty;
+ Is_Parent : constant Boolean := Chars (Id) = Name_uParent;
+ Init_Call_Stmts : List_Id;
+ begin
+ if Is_Parent and then Has_Late_Init_Component (Etype (Id))
+ then
+ Init_Control_Actual :=
+ Make_Mode_Literal (Comp_Loc, Early_Init_Only);
+ -- Parent_Id used later in second call to parent's
+ -- init proc to initialize late-init components.
+ Parent_Id := Id;
+ end if;
+
+ Init_Call_Stmts :=
+ Build_Initialization_Call
+ (Comp_Loc,
+ Make_Selected_Component (Comp_Loc,
+ Prefix =>
+ Make_Identifier (Comp_Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
+ Typ,
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map,
+ Init_Control_Actual => Init_Control_Actual);
+
+ if Is_Parent then
+ -- This is tricky. At first it looks like
+ -- we are going to end up with nested
+ -- if-statements with the same condition:
+ -- if Early_Init_Condition then
+ -- if Early_Init_Condition then
+ -- Parent_TypeIP (...);
+ -- end if;
+ -- end if;
+ -- But later we will hoist the inner if-statement
+ -- out of the outer one; we do this because the
+ -- init-proc call for the _Parent component of a type
+ -- extension has to precede any other initialization.
+ Actions :=
+ New_List (Make_If_Statement (Loc,
+ Condition =>
+ Early_Init_Condition (Loc, Init_Control_Formal),
+ Then_Statements => Init_Call_Stmts));
+ else
+ Actions := Init_Call_Stmts;
+ end if;
+ end;
Clean_Task_Names (Typ, Proc_Id);
@@ -3443,7 +3435,7 @@ package body Exp_Ch3 is
-- DIC here.
if Has_DIC (Typ)
- and then not Present (Expression (Decl))
+ and then No (Expression (Decl))
and then Present (DIC_Procedure (Typ))
and then not Has_Null_Body (DIC_Procedure (Typ))
@@ -3481,7 +3473,6 @@ package body Exp_Ch3 is
if Present (Actions) then
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Actions);
-
else
Append_List_To (Stmts, Actions);
@@ -3595,6 +3586,34 @@ package body Exp_Ch3 is
-- Second pass: components that require late initialization
+ if Present (Parent_Id) then
+ declare
+ Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id));
+ use Initialization_Control;
+ begin
+ -- We are building the init proc for a type extension.
+ -- Call the parent type's init proc a second time, this
+ -- time to initialize the parent's components that require
+ -- late initialization.
+
+ Append_List_To (Late_Stmts,
+ Build_Initialization_Call
+ (Loc => Parent_Loc,
+ Id_Ref =>
+ Make_Selected_Component (Parent_Loc,
+ Prefix => Make_Identifier
+ (Parent_Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Parent_Id,
+ Parent_Loc)),
+ Typ => Etype (Parent_Id),
+ In_Init_Proc => True,
+ Enclos_Type => Rec_Type,
+ Discr_Map => Discr_Map,
+ Init_Control_Actual => Make_Mode_Literal
+ (Parent_Loc, Late_Init_Only)));
+ end;
+ end if;
+
if Has_Late_Init_Comp then
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
@@ -3602,13 +3621,14 @@ package body Exp_Ch3 is
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
- if Requires_Late_Initialization (Decl, Rec_Type) then
+ if Initialization_Control.Requires_Late_Init (Decl, Rec_Type)
+ then
if Present (Expression (Decl)) then
- Append_List_To (Stmts,
+ Append_List_To (Late_Stmts,
Build_Assignment (Id, Expression (Decl)));
elsif Has_Non_Null_Base_Init_Proc (Typ) then
- Append_List_To (Stmts,
+ Append_List_To (Late_Stmts,
Build_Initialization_Call (Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
@@ -3628,10 +3648,10 @@ package body Exp_Ch3 is
Make_Counter (Comp_Loc);
end if;
- Increment_Counter (Comp_Loc);
+ Increment_Counter (Comp_Loc, Late => True);
end if;
elsif Component_Needs_Simple_Initialization (Typ) then
- Append_List_To (Stmts,
+ Append_List_To (Late_Stmts,
Build_Assignment
(Id => Id,
Default =>
@@ -3646,7 +3666,8 @@ package body Exp_Ch3 is
end loop;
end if;
- -- Process the variant part
+ -- Process the variant part (incorrectly ignoring late
+ -- initialization requirements for components therein).
if Present (Variant_Part (Comp_List)) then
declare
@@ -3681,16 +3702,42 @@ package body Exp_Ch3 is
end;
end if;
- -- If no initializations when generated for component declarations
- -- corresponding to this Stmts, append a null statement to Stmts to
- -- to make it a valid Ada tree.
+ if No (Init_Control_Formal) then
+ Append_List_To (Stmts, Late_Stmts);
- if Is_Empty_List (Stmts) then
- Append (Make_Null_Statement (Loc), Stmts);
- end if;
+ -- If no initializations were generated for component declarations
+ -- and included in Stmts, then append a null statement to Stmts
+ -- to make it a valid Ada tree.
- return Stmts;
+ if Is_Empty_List (Stmts) then
+ Append (Make_Null_Statement (Loc), Stmts);
+ end if;
+ return Stmts;
+ else
+ declare
+ use Initialization_Control;
+
+ If_Early : constant Node_Id :=
+ (if Is_Empty_List (Stmts) then
+ Make_Null_Statement (Loc)
+ else
+ Make_If_Statement (Loc,
+ Condition =>
+ Early_Init_Condition (Loc, Init_Control_Formal),
+ Then_Statements => Stmts));
+ If_Late : constant Node_Id :=
+ (if Is_Empty_List (Late_Stmts) then
+ Make_Null_Statement (Loc)
+ else
+ Make_If_Statement (Loc,
+ Condition =>
+ Late_Init_Condition (Loc, Init_Control_Formal),
+ Then_Statements => Late_Stmts));
+ begin
+ return New_List (If_Early, If_Late);
+ end;
+ end if;
exception
when RE_Not_Available =>
return Empty_List;
@@ -9048,6 +9095,230 @@ package body Exp_Ch3 is
return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
end In_Runtime;
+ package body Initialization_Control is
+
+ ------------------------
+ -- Requires_Late_Init --
+ ------------------------
+
+ function Requires_Late_Init
+ (Decl : Node_Id;
+ Rec_Type : Entity_Id) return Boolean
+ is
+ References_Current_Instance : Boolean := False;
+ Has_Access_Discriminant : Boolean := False;
+ Has_Internal_Call : Boolean := False;
+
+ function Find_Access_Discriminant
+ (N : Node_Id) return Traverse_Result;
+ -- Look for a name denoting an access discriminant
+
+ function Find_Current_Instance
+ (N : Node_Id) return Traverse_Result;
+ -- Look for a reference to the current instance of the type
+
+ function Find_Internal_Call
+ (N : Node_Id) return Traverse_Result;
+ -- Look for an internal protected function call
+
+ ------------------------------
+ -- Find_Access_Discriminant --
+ ------------------------------
+
+ function Find_Access_Discriminant
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Denotes_Discriminant (N)
+ and then Is_Access_Type (Etype (N))
+ then
+ Has_Access_Discriminant := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Access_Discriminant;
+
+ ---------------------------
+ -- Find_Current_Instance --
+ ---------------------------
+
+ function Find_Current_Instance
+ (N : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Current_Instance (N)
+ then
+ References_Current_Instance := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Current_Instance;
+
+ ------------------------
+ -- Find_Internal_Call --
+ ------------------------
+
+ function Find_Internal_Call (N : Node_Id) return Traverse_Result is
+
+ function Call_Scope (N : Node_Id) return Entity_Id;
+ -- Return the scope enclosing a given call node N
+
+ ----------------
+ -- Call_Scope --
+ ----------------
+
+ function Call_Scope (N : Node_Id) return Entity_Id is
+ Nam : constant Node_Id := Name (N);
+ begin
+ if Nkind (Nam) = N_Selected_Component then
+ return Scope (Entity (Prefix (Nam)));
+ else
+ return Scope (Entity (Nam));
+ end if;
+ end Call_Scope;
+
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Call_Scope (N)
+ = Corresponding_Concurrent_Type (Rec_Type)
+ then
+ Has_Internal_Call := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Find_Internal_Call;
+
+ procedure Search_Access_Discriminant is new
+ Traverse_Proc (Find_Access_Discriminant);
+
+ procedure Search_Current_Instance is new
+ Traverse_Proc (Find_Current_Instance);
+
+ procedure Search_Internal_Call is new
+ Traverse_Proc (Find_Internal_Call);
+
+ -- Start of processing for Requires_Late_Init
+
+ begin
+ -- A component of an object is said to require late initialization
+ -- if:
+
+ -- it has an access discriminant value constrained by a per-object
+ -- expression;
+
+ if Has_Access_Constraint (Defining_Identifier (Decl))
+ and then No (Expression (Decl))
+ then
+ return True;
+
+ elsif Present (Expression (Decl)) then
+
+ -- it has an initialization expression that includes a name
+ -- denoting an access discriminant;
+
+ Search_Access_Discriminant (Expression (Decl));
+
+ if Has_Access_Discriminant then
+ return True;
+ end if;
+
+ -- or it has an initialization expression that includes a
+ -- reference to the current instance of the type either by
+ -- name...
+
+ Search_Current_Instance (Expression (Decl));
+
+ if References_Current_Instance then
+ return True;
+ end if;
+
+ -- ...or implicitly as the target object of a call.
+
+ if Is_Protected_Record_Type (Rec_Type) then
+ Search_Internal_Call (Expression (Decl));
+
+ if Has_Internal_Call then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Requires_Late_Init;
+
+ -----------------------------
+ -- Has_Late_Init_Component --
+ -----------------------------
+
+ function Has_Late_Init_Component
+ (Tagged_Rec_Type : Entity_Id) return Boolean
+ is
+ Comp_Id : Entity_Id :=
+ First_Component (Implementation_Base_Type (Tagged_Rec_Type));
+ begin
+ while Present (Comp_Id) loop
+ if Requires_Late_Init (Decl => Parent (Comp_Id),
+ Rec_Type => Tagged_Rec_Type)
+ then
+ return True; -- found a component that requires late init
+
+ elsif Chars (Comp_Id) = Name_uParent
+ and then Has_Late_Init_Component (Etype (Comp_Id))
+ then
+ return True; -- an ancestor type has a late init component
+ end if;
+
+ Next_Component (Comp_Id);
+ end loop;
+
+ return False;
+ end Has_Late_Init_Component;
+
+ ------------------------
+ -- Tag_Init_Condition --
+ ------------------------
+
+ function Tag_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id is
+ begin
+ return Make_Op_Eq (Loc,
+ New_Occurrence_Of (Init_Control_Formal, Loc),
+ Make_Mode_Literal (Loc, Full_Init));
+ end Tag_Init_Condition;
+
+ --------------------------
+ -- Early_Init_Condition --
+ --------------------------
+
+ function Early_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id is
+ begin
+ return Make_Op_Ne (Loc,
+ New_Occurrence_Of (Init_Control_Formal, Loc),
+ Make_Mode_Literal (Loc, Late_Init_Only));
+ end Early_Init_Condition;
+
+ -------------------------
+ -- Late_Init_Condition --
+ -------------------------
+
+ function Late_Init_Condition
+ (Loc : Source_Ptr;
+ Init_Control_Formal : Entity_Id) return Node_Id is
+ begin
+ return Make_Op_Ne (Loc,
+ New_Occurrence_Of (Init_Control_Formal, Loc),
+ Make_Mode_Literal (Loc, Early_Init_Only));
+ end Late_Init_Condition;
+
+ end Initialization_Control;
+
----------------------------
-- Initialization_Warning --
----------------------------
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 8b2c3062a0a..23fecfd3cb9 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -62,14 +62,15 @@ package Exp_Ch3 is
-- and the discriminant checking functions are inserted after this node.
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False;
- Constructor_Ref : Node_Id := Empty) return List_Id;
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty;
+ Init_Control_Actual : Entity_Id := Empty) return List_Id;
-- Builds a call to the initialization procedure for the base type of Typ,
-- passing it the object denoted by Id_Ref, plus additional parameters as
-- appropriate for the type (the _Master, for task types, for example).
@@ -93,6 +94,12 @@ package Exp_Ch3 is
--
-- Constructor_Ref is a call to a constructor subprogram. It is currently
-- used only to support C++ constructors.
+ --
+ -- Init_Control_Actual is Empty except in the case where the init proc
+ -- for a tagged type calls the init proc for its parent type in order
+ -- to initialize its _Parent component. In that case, it is the
+ -- actual parameter value corresponding to the Init_Control formal
+ -- parameter to be used in the call of the parent type's init proc.
function Build_Variant_Record_Equality
(Typ : Entity_Id;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index cd497ee453b..4198ceaa5b3 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -4377,6 +4377,12 @@ package body Exp_Util is
and then
Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
+ Component_Suffix_Index : constant Int :=
+ (if In_Init_Proc then -1 else 0);
+ -- If an init proc calls Build_Task_Image_Decls twice for its
+ -- _Parent component (to split early/late initialization), we don't
+ -- want two decls with the same name. Hence, the -1 suffix.
+
begin
-- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
-- generate a dummy declaration only.
@@ -4418,7 +4424,8 @@ package body Exp_Util is
elsif Nkind (Id_Ref) = N_Selected_Component then
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
+ New_External_Name (Chars (Selector_Name (Id_Ref)), 'T',
+ Suffix_Index => Component_Suffix_Index));
Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
elsif Nkind (Id_Ref) = N_Indexed_Component then
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-13 8:08 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-13 8:08 [gcc r13-400] [Ada] Implement late initialization rules for type extensions Pierre-Marie de Rodat
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).