From: Eric Botcazou <ebotca...@adacore.com>
This makes the compiler generate cleanup code to deallocate the memory when
the evaluation of the expression of an allocator raises an exception, if the
expression is a call to a function that may raise, i.e. is not declared with
the No_Raise aspect/pragma. This can also be disabled by means of -gnatdQ.
gcc/ada/ChangeLog:
* debug.adb (dQ): Document usage.
* exp_ch4.ads (Build_Cleanup_For_Allocator): New declaration.
* exp_ch4.adb (Build_Cleanup_For_Allocator): New procedure.
(Expand_Allocator_Expression): Build a cleanup to deallocate the
memory when the evaluation of the expression raises an exception.
* exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Likewise.
* exp_util.adb (Build_Allocate_Deallocate_Proc): Do not generate the
detachment if the deallocation is for the cleanup of an allocator.
* gen_il-fields.ads (Opt_Field_Enum): Add For_Allocator.
* gen_il-gen-gen_nodes.adb (N_Free_Statement): Likewise.
* sinfo.ads (For_Allocator): Document usage on N_Free_Statement.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/debug.adb | 5 +-
gcc/ada/exp_ch4.adb | 123 +++++++++++++++++++++++++------
gcc/ada/exp_ch4.ads | 9 +++
gcc/ada/exp_ch6.adb | 16 +++-
gcc/ada/exp_util.adb | 5 ++
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_nodes.adb | 3 +-
gcc/ada/sinfo.ads | 5 ++
8 files changed, 140 insertions(+), 27 deletions(-)
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 2d0c32b0f09..c4b6d035e5c 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -74,7 +74,7 @@ package body Debug is
-- dN No file name information in exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
- -- dQ
+ -- dQ Do not generate cleanups for qualified expressions of allocators
-- dR Bypass check for correct version of s-rpc
-- dS Never convert numbers to machine numbers in Sem_Eval
-- dT Convert to machine numbers only for constant declarations
@@ -640,6 +640,9 @@ package body Debug is
-- in preelaborable packages, but this restriction is a huge pain,
-- especially in the predefined library units.
+ -- dQ Do not generate cleanups to deallocate the memory in case qualified
+ -- expressions of allocators raise an exception.
+
-- dR Bypass the check for a proper version of s-rpc being present
-- to use the -gnatz? switch. This allows debugging of the use
-- of stubs generation without needing to have GLADE (or some
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 18656ea24fd..75d79019f80 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -437,6 +437,37 @@ package body Exp_Ch4 is
return;
end Build_Boolean_Array_Proc_Call;
+ ---------------------------------
+ -- Build_Cleanup_For_Allocator --
+ ---------------------------------
+
+ function Build_Cleanup_For_Allocator
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Pool : Entity_Id;
+ Actions : List_Id) return Node_Id
+ is
+ Free_Stmt : constant Node_Id :=
+ Make_Free_Statement (Loc, New_Occurrence_Of (Obj_Id, Loc));
+
+ begin
+ Set_For_Allocator (Free_Stmt);
+ Set_Storage_Pool (Free_Stmt, Pool);
+
+ return
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Actions,
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Free_Stmt,
+ Make_Raise_Statement (Loc))))));
+ end Build_Cleanup_For_Allocator;
+
-----------------------
-- Build_Eq_Call --
-----------------------
@@ -574,7 +605,12 @@ package body Exp_Ch4 is
T : constant Entity_Id := Entity (Indic);
PtrT : constant Entity_Id := Etype (N);
DesigT : constant Entity_Id := Designated_Type (PtrT);
+ Pool : constant Node_Id := Storage_Pool (N);
Special_Return : constant Boolean := For_Special_Return_Object (N);
+ Special_Pool : constant Boolean :=
+ Present (Pool)
+ and then
+ (Is_RTE (Pool, RE_RS_Pool) or else Is_RTE (Pool, RE_SS_Pool));
Static_Match : constant Boolean :=
not Is_Constrained (DesigT)
or else Subtypes_Statically_Match (T, DesigT);
@@ -586,8 +622,7 @@ package body Exp_Ch4 is
-- of Exp into the newly allocated memory.
procedure Build_Explicit_Assignment (Temp : Entity_Id; Typ : Entity_Id);
- -- If Exp is a conditional expression whose expansion has been delayed,
- -- build the declaration of object Temp with Typ and initialization
+ -- Build the declaration of object Temp with Typ and initialization
-- expression an uninitialized allocator for Etype (Exp), then perform
-- assignment of Exp into the newly allocated memory.
@@ -595,6 +630,22 @@ package body Exp_Ch4 is
-- Build the declaration of object Temp with Typ and initialization
-- expression the allocator N.
+ function Needs_Cleanup return Boolean is
+ (not Special_Pool
+ and then Is_Definite_Subtype (T)
+ and then Nkind (Exp) = N_Function_Call
+ and then not (Is_Entity_Name (Name (Exp))
+ and then No_Raise (Entity (Name (Exp))))
+ and then RTE_Available (RE_Free)
+ and then not Debug_Flag_QQ);
+ -- Return True if a cleanup needs to be built to deallocate the memory
+ -- when the evaluation of the expression raises an exception. This can
+ -- be done only if deallocation is available, but not for special pools
+ -- since such pools do not support deallocation. Moreover, this is not
+ -- needed for an indefinite allocation because the expression will be
+ -- evaluated first, in order to size the allocation. For now, we only
+ -- return True for a call to a function that may raise an exception.
+
------------------------------
-- Build_Aggregate_In_Place --
------------------------------
@@ -665,10 +716,32 @@ package body Exp_Ch4 is
-- Arrange for the expression to be analyzed again and expanded
+ if Is_Delayed_Conditional_Expression (Expression (Assign)) then
+ Unanalyze_Delayed_Conditional_Expression (Expression (Assign));
+ end if;
+
Set_Assignment_OK (Name (Assign));
- Set_Analyzed (Expression (Assign), False);
- Set_No_Finalize_Actions (Assign);
- Insert_Action (N, Assign);
+
+ -- If the initialization expression is a function call, we do not
+ -- adjust after the assignment but, in either case, we do not
+ -- finalize before since the target is newly allocated memory.
+
+ if Nkind (Exp) = N_Function_Call then
+ Set_No_Ctrl_Actions (Assign);
+ else
+ Set_No_Finalize_Actions (Assign);
+ end if;
+
+ -- Build a cleanup if the assignment may raise an exception
+
+ if Needs_Cleanup then
+ Insert_Action (N,
+ Build_Cleanup_For_Allocator (Loc,
+ Temp, Pool, New_List (Assign)),
+ Suppress => All_Checks);
+ else
+ Insert_Action (N, Assign, Suppress => All_Checks);
+ end if;
end Build_Explicit_Assignment;
-----------------------------
@@ -871,6 +944,20 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Expression (N), Entity (Indic));
end if;
+ -- If the designated type is class-wide, then the alignment and the
+ -- controlled nature of the expression are computed dynamically by
+ -- the code generated by Build_Allocate_Deallocate_Proc, which will
+ -- thus need to remove side effects from Exp first. But the below
+ -- test on Exp needs to have its final form to decide whether or not
+ -- to generate an Adjust call, so we preventively remove them here.
+
+ if Is_Class_Wide_Type (DesigT)
+ and then Nkind (Exp) = N_Function_Call
+ and then not Special_Pool
+ then
+ Remove_Side_Effects (Exp);
+ end if;
+
-- Actions inserted before:
-- Temp : constant PtrT := new T'(Expression);
-- Temp._tag = T'tag; -- when not class-wide
@@ -887,7 +974,7 @@ package body Exp_Ch4 is
if Aggr_In_Place then
Build_Aggregate_In_Place (Temp, PtrT);
- elsif Delayed_Cond_Expr then
+ elsif Delayed_Cond_Expr or else Needs_Cleanup then
Build_Explicit_Assignment (Temp, PtrT);
else
@@ -929,7 +1016,7 @@ package body Exp_Ch4 is
if Aggr_In_Place then
Build_Aggregate_In_Place (New_Temp, Def_Id);
- elsif Delayed_Cond_Expr then
+ elsif Delayed_Cond_Expr or else Needs_Cleanup then
Build_Explicit_Assignment (New_Temp, Def_Id);
else
@@ -995,22 +1082,6 @@ package body Exp_Ch4 is
(Loc, TagR, Underlying_Type (TagT)));
end if;
- -- If the designated type is class-wide, then the alignment and the
- -- controlled nature of the expression are computed dynamically by
- -- the code generated by Build_Allocate_Deallocate_Proc, which will
- -- thus need to remove side effects from Exp first. But the below
- -- test on Exp needs to have its final form to decide whether or not
- -- to generate an Adjust call, so we preventively remove them here.
-
- if Nkind (Exp) = N_Function_Call
- and then Is_Class_Wide_Type (DesigT)
- and then Present (Storage_Pool (N))
- and then not Is_RTE (Storage_Pool (N), RE_RS_Pool)
- and then not Is_RTE (Storage_Pool (N), RE_SS_Pool)
- then
- Remove_Side_Effects (Exp);
- end if;
-
-- Generate an Adjust call if the object will be moved. In Ada 2005,
-- the object may be inherently limited, in which case there is no
-- Adjust procedure, and the object is built in place. In Ada 95, the
@@ -1141,7 +1212,11 @@ package body Exp_Ch4 is
end if;
Temp := Make_Temporary (Loc, 'P', N);
- Build_Simple_Allocation (Temp, PtrT);
+ if Needs_Cleanup then
+ Build_Explicit_Assignment (Temp, PtrT);
+ else
+ Build_Simple_Allocation (Temp, PtrT);
+ end if;
Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
end if;
diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads
index 22ffdc6496d..69914561e97 100644
--- a/gcc/ada/exp_ch4.ads
+++ b/gcc/ada/exp_ch4.ads
@@ -73,6 +73,15 @@ package Exp_Ch4 is
procedure Expand_N_Type_Conversion (N : Node_Id);
procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id);
+ function Build_Cleanup_For_Allocator
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Pool : Entity_Id;
+ Actions : List_Id) return Node_Id;
+ -- Build a cleanup for the list of Actions that will deallocate the memory
+ -- allocated in Pool and designated by Obj_Id if the execution of Actions
+ -- raises an exception.
+
function Build_Eq_Call
(Typ : Entity_Id;
Loc : Source_Ptr;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 11b954fbabd..a339a223f09 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -8499,7 +8499,21 @@ package body Exp_Ch6 is
Chain := Empty;
end if;
- Insert_Actions (Allocator, Actions);
+ -- See the Needs_Cleanup predicate in Expand_Allocator_Expression
+
+ if Alloc_Form = Caller_Allocation
+ and then not For_Special_Return_Object (Allocator)
+ and then not (Is_Entity_Name (Name (Func_Call))
+ and then No_Raise (Entity (Name (Func_Call))))
+ and then RTE_Available (RE_Free)
+ and then not Debug_Flag_QQ
+ then
+ Insert_Action (Allocator,
+ Build_Cleanup_For_Allocator (Loc,
+ Return_Obj_Access, Storage_Pool (Allocator), Actions));
+ else
+ Insert_Actions (Allocator, Actions);
+ end if;
end;
-- When the function has a controlling result, an allocation-form
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 25f9f077174..66ba73226ed 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1281,6 +1281,11 @@ package body Exp_Util is
end if;
end;
+ -- Nothing to generate for the cleanup of an allocator
+
+ elsif For_Allocator (N) then
+ null;
+
-- Generate:
-- if F then
-- Detach_Object_From_Collection (Temp.all'Address);
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index b2a498003d8..52c6997e6c9 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -192,6 +192,7 @@ package Gen_IL.Fields is
Float_Truncate,
Formal_Type_Definition,
Forwards_OK,
+ For_Allocator,
For_Special_Return_Object,
From_Aspect_Specification,
From_At_Mod,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index c83f9ac3ddb..9b8801b4b84 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -948,7 +948,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Expression, Node_Id, Default_Empty),
Sm (Actual_Designated_Subtype, Node_Id),
Sm (Procedure_To_Call, Node_Id),
- Sm (Storage_Pool, Node_Id)));
+ Sm (Storage_Pool, Node_Id),
+ Sm (For_Allocator, Flag)));
Cc (N_Goto_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Name, Node_Id, Default_Empty),
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 2e1ac250c93..3db084ef391 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1339,6 +1339,10 @@ package Sinfo is
-- cannot figure it out. If both flags Forwards_OK and Backwards_OK are
-- set, it means that the front end can assure no overlap of operands.
+ -- For_Allocator
+ -- Present in N_Free_Statement nodes. True if the statement is generated
+ -- for the cleanup of an allocator.
+
-- For_Special_Return_Object
-- Present in N_Allocator nodes. True if the allocator is generated for
-- the initialization of a special return object.
@@ -8110,6 +8114,7 @@ package Sinfo is
-- Storage_Pool
-- Procedure_To_Call
-- Actual_Designated_Subtype
+ -- For_Allocator
-- Note: in the case where a debug source file is generated, the Sloc
-- for this node points to the FREE keyword in the Sprint file output.
--
2.43.0
