From 7067e6f6ff9bf9c640a8f1e3193fad195d20f6c3 Mon Sep 17 00:00:00 2001
From: Eric Botcazou <ebotcazou@adacore.com>
Date: Tue, 10 Dec 2024 19:43:14 +0100
Subject: [PATCH] ada: Fix memory leak when failing to initialize newly
allocated memory
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.
---
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 2d0c32b0f094..c4b6d035e5cf 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 18656ea24fdb..75d79019f807 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 22ffdc6496d1..69914561e97d 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 11b954fbabd5..a339a223f09f 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 25f9f077174b..66ba73226ed0 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 b2a498003d8d..52c6997e6c9b 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 c83f9ac3ddb1..9b8801b4b845 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 2e1ac250c93f..3db084ef391f 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.
--
GitLab