From: Eric Botcazou <ebotca...@adacore.com>
The generic finalization machinery and the finalization machinery for
transient objects disagree on which controlled objects should be finalized
indirectly, i.e. through an access value: the former only considers return
objects of (selected) function calls, whereas the latter considers all
objects designated by a reference, which means that it must be careful
about not finalizing them twice.
The discrepancy does not seem to cause problems in practice, but is awkward
and creates additional work for the finalization machinery for transient
objects, as well as code duplication.
gcc/ada/ChangeLog:
* exp_util.ads (Is_Finalizable_Access): New predicate.
(Is_Non_BIP_Func_Call): Delete.
(Is_Secondary_Stack_BIP_Func_Call): Likewise.
* exp_util.adb (Is_Finalizable_Access): New predicate.
(Initialized_By_Aliased_BIP_Func_Call): Delete.
(Initialized_By_Reference): Likewise.
(Is_Aliased): Only consider the nontransient object serviced by
the transient scope.
(Is_Part_Of_BIP_Return_Statement): Minor tweak.
(Is_Finalizable_Transient): Remove calls to Initialized_By_Reference
and Initialized_By_Aliased_BIP_Func_Call.
Call Is_Finalizable_Access for access objects.
(Is_Non_BIP_Func_Call): Delete.
(Is_Secondary_Stack_BIP_Func_Call): Likewise.
(Requires_Cleanup_Actions): Call Is_Finalizable_Access for access
objects.
(Side_Effect_Free): Return True for N_Reference.
* exp_ch7.adb (Build_Finalizer.Process_Declarations): Call
Is_Finalizable_Access for access objects.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 17 +--
gcc/ada/exp_util.adb | 348 +++++++++++++++----------------------------
gcc/ada/exp_util.ads | 15 +-
3 files changed, 127 insertions(+), 253 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 1c569b90dd2..5fec6915997 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -2466,7 +2466,6 @@ package body Exp_Ch7 is
-- Local variables
Decl : Node_Id;
- Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
@@ -2516,7 +2515,6 @@ package body Exp_Ch7 is
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
@@ -2572,21 +2570,10 @@ package body Exp_Ch7 is
Processing_Actions
(Decl, Strict => not Has_Relaxed_Finalization (Obj_Typ));
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
-
- -- Obj : Access_Typ :=
- -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
+ -- The object is an access-to-controlled that must be finalized
elsif Is_Access_Type (Obj_Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Obj_Typ)))
- and then Present (Expr)
- and then
- (Is_Secondary_Stack_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ and then Is_Finalizable_Access (Decl)
then
Processing_Actions
(Decl,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 0606db4edae..ffaf4541146 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8869,6 +8869,83 @@ package body Exp_Util is
and then Is_Return_Object (Defining_Entity (Par)));
end Is_Expression_Of_Func_Return;
+ ---------------------------
+ -- Is_Finalizable_Access --
+ ---------------------------
+
+ function Is_Finalizable_Access (Decl : Node_Id) return Boolean is
+ Obj : constant Entity_Id := Defining_Identifier (Decl);
+ Typ : constant Entity_Id := Base_Type (Etype (Obj));
+ Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
+ Expr : constant Node_Id := Expression (Decl);
+
+ Secondary_Stack_Val : constant Uint :=
+ UI_From_Int (BIP_Allocation_Form'Pos (Secondary_Stack));
+
+ Actual : Node_Id;
+ Call : Node_Id;
+ Formal : Node_Id;
+ Param : Node_Id;
+
+ begin
+ -- The prerequisite is a reference to a controlled object
+
+ if No (Expr)
+ or else Nkind (Expr) /= N_Reference
+ or else not Needs_Finalization (Desig)
+ then
+ return False;
+ end if;
+
+ Call := Unqual_Conv (Prefix (Expr));
+
+ -- For a BIP function call, the only case where the return object needs
+ -- to be finalized through Obj is when it is allocated on the secondary
+ -- stack; when it is allocated in the caller, it is finalized directly,
+ -- and when it is allocated on the global heap or in a storage pool, it
+ -- is finalized through another mechanism.
+
+ -- Obj : Access_Typ :=
+ -- BIP_Function_Call (BIPalloc => Secondary_Stack, ...)'reference;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- A match for BIPalloc => Secondary_Stack has been found
+
+ if Is_Build_In_Place_Entity (Formal)
+ and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Secondary_Stack_Val
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+
+ -- For a non-BIP function call, the only case where the return object
+ -- need not be finalized is when it itself is going to be returned.
+
+ -- Obj : Typ := Non_BIP_Function_Call'reference;
+
+ elsif Nkind (Call) = N_Function_Call
+ and then not Is_Related_To_Func_Return (Obj)
+ then
+ return True;
+ end if;
+
+ return False;
+ end Is_Finalizable_Access;
+
------------------------------
-- Is_Finalizable_Transient --
------------------------------
@@ -8880,19 +8957,6 @@ package body Exp_Util is
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- function Initialized_By_Aliased_BIP_Func_Call
- (Trans_Id : Entity_Id) return Boolean;
- -- Determine whether transient object Trans_Id is initialized by a
- -- build-in-place function call where the BIPalloc parameter either
- -- does not exist or is Caller_Allocation, and BIPaccess is not null.
- -- This case creates an aliasing between the returned value and the
- -- value denoted by BIPaccess.
-
- function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean;
- -- Determine whether transient object Trans_Id is initialized by a
- -- reference to another object. This is the only case where we can
- -- possibly finalize a transient object through an access value.
-
function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean;
@@ -8918,115 +8982,6 @@ package body Exp_Util is
-- Return True if N is directly part of a build-in-place return
-- statement.
- ------------------------------------------
- -- Initialized_By_Aliased_BIP_Func_Call --
- ------------------------------------------
-
- function Initialized_By_Aliased_BIP_Func_Call
- (Trans_Id : Entity_Id) return Boolean
- is
- Call : Node_Id := Expression (Parent (Trans_Id));
-
- begin
- -- Build-in-place calls usually appear in 'reference format
-
- if Nkind (Call) = N_Reference then
- Call := Prefix (Call);
- end if;
-
- Call := Unqual_Conv (Call);
-
- -- We search for a formal with a matching suffix. We can't search
- -- for the full name, because of the code at the end of Sem_Ch6.-
- -- Create_Extra_Formals, which copies the Extra_Formals over to
- -- the Alias of an instance, which will cause the formals to have
- -- "incorrect" names. See also Exp_Ch6.Build_In_Place_Formal.
-
- if Is_Build_In_Place_Function_Call (Call) then
- declare
- Caller_Allocation_Val : constant Uint :=
- UI_From_Int (BIP_Allocation_Form'Pos (Caller_Allocation));
- Access_Suffix : constant String :=
- BIP_Formal_Suffix (BIP_Object_Access);
- Alloc_Suffix : constant String :=
- BIP_Formal_Suffix (BIP_Alloc_Form);
-
- function Has_Suffix (Name, Suffix : String) return Boolean;
- -- Return True if Name has suffix Suffix
-
- ----------------
- -- Has_Suffix --
- ----------------
-
- function Has_Suffix (Name, Suffix : String) return Boolean is
- Len : constant Natural := Suffix'Length;
-
- begin
- return Name'Length > Len
- and then Name (Name'Last - Len + 1 .. Name'Last) = Suffix;
- end Has_Suffix;
-
- Access_OK : Boolean := False;
- Alloc_OK : Boolean := True;
- Param : Node_Id;
-
- begin
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
-
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
- declare
- Actual : constant Node_Id :=
- Explicit_Actual_Parameter (Param);
- Formal : constant Node_Id :=
- Selector_Name (Param);
- Name : constant String :=
- Get_Name_String (Chars (Formal));
-
- begin
- -- A nonnull BIPaccess has been found
-
- if Has_Suffix (Name, Access_Suffix)
- and then Nkind (Actual) /= N_Null
- then
- Access_OK := True;
-
- -- A BIPalloc has been found
-
- elsif Has_Suffix (Name, Alloc_Suffix)
- and then Nkind (Actual) = N_Integer_Literal
- then
- Alloc_OK := Intval (Actual) = Caller_Allocation_Val;
- end if;
- end;
- end if;
-
- Next (Param);
- end loop;
-
- return Access_OK and Alloc_OK;
- end;
- end if;
-
- return False;
- end Initialized_By_Aliased_BIP_Func_Call;
-
- ------------------------------
- -- Initialized_By_Reference --
- ------------------------------
-
- function Initialized_By_Reference (Trans_Id : Entity_Id) return Boolean
- is
- Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
- begin
- return Present (Expr) and then Nkind (Expr) = N_Reference;
- end Initialized_By_Reference;
-
----------------
-- Is_Aliased --
----------------
@@ -9132,13 +9087,16 @@ package body Exp_Util is
Stmt := First_Stmt;
while Present (Stmt) loop
- -- Transient objects initialized by a reference are finalized
- -- (see Initialized_By_Reference above), so we must make sure
- -- not to finalize the referenced object twice. And we cannot
- -- finalize it at all if it is referenced by the nontransient
- -- object serviced by the transient scope.
+ -- (Transient) objects initialized by a reference to another named
+ -- object are never finalized (see Is_Finalizable_Access), so we
+ -- need not worry about finalizing (transient) referenced objects
+ -- twice. Therefore, we only need to look at the nontransient
+ -- object serviced by the transient scope, if it exists and is
+ -- declared as a reference to another named object.
- if Nkind (Stmt) = N_Object_Declaration then
+ if Nkind (Stmt) = N_Object_Declaration
+ and then Stmt = N
+ then
Expr := Expression (Stmt);
-- Aliasing of the form:
@@ -9152,8 +9110,8 @@ package body Exp_Util is
return True;
end if;
- -- (Transient) renamings are never finalized so we need not bother
- -- about finalizing transient renamed objects twice. Therefore, we
+ -- (Transient) renamings are never finalized so we need not worry
+ -- about finalizing (transient) renamed objects twice. Therefore,
-- we only need to look at the nontransient object serviced by the
-- transient scope, if it exists and is declared as a renaming.
@@ -9353,12 +9311,11 @@ package body Exp_Util is
function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
Subp : constant Entity_Id := Current_Subprogram;
Context : Node_Id;
+
begin
-- First check if N is part of a BIP function
- if No (Subp)
- or else not Is_Build_In_Place_Function (Subp)
- then
+ if No (Subp) or else not Is_Build_In_Place_Function (Subp) then
return False;
end if;
@@ -9382,6 +9339,15 @@ package body Exp_Util is
-- Start of processing for Is_Finalizable_Transient
begin
+ -- If the node serviced by the transient context is a return statement,
+ -- then the finalization needs to be deferred to the generic machinery.
+
+ if Nkind (N) = N_Simple_Return_Statement
+ or else Is_Part_Of_BIP_Return_Statement (N)
+ then
+ return False;
+ end if;
+
-- Handle access types
if Is_Access_Type (Desig) then
@@ -9391,35 +9357,28 @@ package body Exp_Util is
return
Ekind (Obj_Id) in E_Constant | E_Variable
and then Needs_Finalization (Desig)
- and then Nkind (N) /= N_Simple_Return_Statement
- and then not Is_Part_Of_BIP_Return_Statement (N)
-- Do not consider a transient object that was already processed
and then not Is_Finalized_Transient (Obj_Id)
- -- Do not consider renamed or 'reference-d transient objects because
- -- the act of renaming extends the object's lifetime.
-
- and then not Is_Aliased (Obj_Id, Decl)
-
- -- If the transient object is of an access type, check that it is
- -- initialized by a reference to another object.
-
- and then (not Is_Access_Type (Obj_Typ)
- or else Initialized_By_Reference (Obj_Id))
-
- -- Do not consider transient objects which act as indirect aliases
- -- of build-in-place function results.
-
- and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
-
-- Do not consider iterators because those are treated as normal
-- controlled objects and are processed by the usual finalization
-- machinery. This avoids the double finalization of an iterator.
and then not Is_Iterator (Desig)
+ -- If the transient object is of an access type, check that it must
+ -- be finalized.
+
+ and then (not Is_Access_Type (Obj_Typ)
+ or else Is_Finalizable_Access (Decl))
+
+ -- Do not consider renamed transient objects because the act of
+ -- renaming extends the object's lifetime.
+
+ and then not Is_Aliased (Obj_Id, Decl)
+
-- Do not consider containers in the context of iterator loops. Such
-- transient objects must exist for as long as the loop is around,
-- otherwise any operation carried out by the iterator will fail.
@@ -9487,22 +9446,6 @@ package body Exp_Util is
and then Present (LSP_Subprogram (E));
end Is_LSP_Wrapper;
- --------------------------
- -- Is_Non_BIP_Func_Call --
- --------------------------
-
- function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
- begin
- -- The expected call is of the format
- --
- -- Func_Call'reference
-
- return
- Nkind (Expr) = N_Reference
- and then Nkind (Prefix (Expr)) = N_Function_Call
- and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
- end Is_Non_BIP_Func_Call;
-
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
@@ -9870,55 +9813,6 @@ package body Exp_Util is
end if;
end Is_Renamed_Object;
- --------------------------------------
- -- Is_Secondary_Stack_BIP_Func_Call --
- --------------------------------------
-
- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Actual : Node_Id;
- Call : Node_Id := Expr;
- Formal : Node_Id;
- Param : Node_Id;
-
- begin
- -- Build-in-place calls usually appear in 'reference format. Note that
- -- the accessibility check machinery may add an extra 'reference due to
- -- side-effect removal.
-
- while Nkind (Call) = N_Reference loop
- Call := Prefix (Call);
- end loop;
-
- Call := Unqual_Conv (Call);
-
- if Is_Build_In_Place_Function_Call (Call) then
-
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association then
- Formal := Selector_Name (Param);
- Actual := Explicit_Actual_Parameter (Param);
-
- -- A match for BIPalloc => 2 has been found
-
- if Is_Build_In_Place_Entity (Formal)
- and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
- and then Nkind (Actual) = N_Integer_Literal
- and then Intval (Actual) = Uint_2
- then
- return True;
- end if;
- end if;
-
- Next (Param);
- end loop;
- end if;
-
- return False;
- end Is_Secondary_Stack_BIP_Func_Call;
-
------------------------------
-- Is_Secondary_Stack_Thunk --
------------------------------
@@ -13588,7 +13482,6 @@ package body Exp_Util is
Nested_Constructs : Boolean) return Boolean
is
Decl : Node_Id;
- Expr : Node_Id;
Obj_Id : Entity_Id;
Obj_Typ : Entity_Id;
Pack_Id : Entity_Id;
@@ -13626,7 +13519,6 @@ package body Exp_Util is
elsif Nkind (Decl) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Decl);
Obj_Typ := Base_Type (Etype (Obj_Id));
- Expr := Expression (Decl);
-- Bypass any form of processing for objects which have their
-- finalization disabled. This applies only to objects at the
@@ -13680,21 +13572,10 @@ package body Exp_Util is
then
return True;
- -- The object is of the form:
- -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
- --
- -- Obj : Access_Typ :=
- -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
+ -- The object is an access-to-controlled that must be finalized
elsif Is_Access_Type (Obj_Typ)
- and then Needs_Finalization
- (Available_View (Designated_Type (Obj_Typ)))
- and then Present (Expr)
- and then
- (Is_Secondary_Stack_BIP_Func_Call (Expr)
- or else
- (Is_Non_BIP_Func_Call (Expr)
- and then not Is_Related_To_Func_Return (Obj_Id)))
+ and then Is_Finalizable_Access (Decl)
then
return True;
@@ -14703,6 +14584,11 @@ package body Exp_Util is
when N_Aggregate =>
return Compile_Time_Known_Aggregate (N);
+ -- A reference is side-effect-free
+
+ when N_Reference =>
+ return True;
+
-- We consider that anything else has side effects. This is a bit
-- crude, but we are pretty close for most common cases, and we
-- are certainly correct (i.e. we never return True when the
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 1306f5ed56c..f90acc5b0f5 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -825,6 +825,14 @@ package Exp_Util is
-- Determine if N is the expanded code for a class-wide interface type
-- object declaration.
+ function Is_Finalizable_Access (Decl : Node_Id) return Boolean;
+ -- Determine whether declaration Decl denotes an access-to-controlled
+ -- object that must be finalized, i.e. both that the designated object
+ -- is controlled and that it must be finalized through this access, in
+ -- particular that it will not be also finalized directly. That is the
+ -- case only for objects initialized by a reference to a function call
+ -- that meet specific conditions.
+
function Is_Finalizable_Transient
(Decl : Node_Id;
N : Node_Id) return Boolean;
@@ -851,9 +859,6 @@ package Exp_Util is
-- preconditions or postconditions affected by overriding (AI12-0195).
-- LSP stands for Liskov Substitution Principle.
- function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
- -- Determine whether node Expr denotes a non build-in-place function call
-
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal
@@ -898,10 +903,6 @@ package Exp_Util is
-- We consider that a (1 .. 2) is a renamed object since it is the prefix
-- of the name in the renaming declaration.
- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean;
- -- Determine whether Expr denotes a build-in-place function which returns
- -- its result on the secondary stack.
-
function Is_Secondary_Stack_Thunk (Id : Entity_Id) return Boolean;
-- Determine whether Id denotes a secondary stack thunk
--
2.43.0
