From: Gary Dismukes <dismu...@adacore.com>
This reverts commit 91b51fc42b167eedaaded6360c490a4306bc5c55.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch6.adb | 49 ++++++++++++++++++++++++++++++---------------
gcc/ada/exp_ch6.ads | 6 ++++--
gcc/ada/exp_ch7.adb | 20 +++++++++---------
3 files changed, 47 insertions(+), 28 deletions(-)
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 58361e10bd9c..5056b1f990fa 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9093,6 +9093,27 @@ package body Exp_Ch6 is
-- tagged, the called function itself must perform the allocation of
-- the return object, so we pass parameters indicating that.
+ -- But that's also the case when the result subtype needs finalization
+ -- actions because the caller side allocation may result in undesirable
+ -- finalization. Consider the following example:
+ --
+ -- function Make_Lim_Ctrl return Lim_Ctrl is
+ -- begin
+ -- return Result : Lim_Ctrl := raise Program_Error do
+ -- null;
+ -- end return;
+ -- end Make_Lim_Ctrl;
+ --
+ -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl);
+ --
+ -- Even though the size of limited controlled type Lim_Ctrl is known,
+ -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's
+ -- finalization collection. The subsequent call to Make_Lim_Ctrl will
+ -- fail during the initialization actions for Result, which means that
+ -- Result (and Obj by extension) should not be finalized. However Obj
+ -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope
+ -- since it is already attached on the its finalization collection.
+
if Needs_BIP_Alloc_Form (Function_Id) then
Temp_Init := Empty;
@@ -9257,7 +9278,11 @@ package body Exp_Ch6 is
end if;
end;
- -- Add implicit actuals for the BIP formal parameters, if any
+ -- When the function has a controlling result, an allocation-form
+ -- parameter must be passed indicating that the caller is allocating
+ -- the result object. This is needed because such a function can be
+ -- called as a dispatching operation and must be treated similarly
+ -- to functions with unconstrained result subtypes.
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call,
@@ -9282,14 +9307,6 @@ package body Exp_Ch6 is
Add_Access_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Return_Obj_Actual);
- -- If the allocation is done in the caller, create a custom Allocate
- -- procedure if need be.
-
- if not Needs_BIP_Alloc_Form (Function_Id) then
- Build_Allocate_Deallocate_Proc
- (Declaration_Node (Return_Obj_Access), Mark => Allocator);
- end if;
-
-- Finally, replace the allocator node with a reference to the temp
Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc));
@@ -9751,7 +9768,7 @@ package body Exp_Ch6 is
-- ensure that the heap allocation can properly chain the object
-- and later finalize it when the library unit goes out of scope.
- if Needs_BIP_Collection (Function_Id) then
+ if Needs_BIP_Collection (Func_Call) then
Build_Finalization_Collection
(Typ => Ptr_Typ,
For_Lib_Level => True,
@@ -10314,12 +10331,6 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
- -- No need for BIP_Collection if allocation is always done in the caller
-
- if not Needs_BIP_Alloc_Form (Func_Id) then
- return False;
- end if;
-
-- A formal for the finalization collection is needed for build-in-place
-- functions whose result type needs finalization or is a tagged type.
-- Tagged primitive build-in-place functions need such a formal because
@@ -10344,6 +10355,12 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
+ -- See Make_Build_In_Place_Call_In_Allocator for the rationale
+
+ if Needs_BIP_Collection (Func_Id) then
+ return True;
+ end if;
+
-- A formal giving the allocation method is needed for build-in-place
-- functions whose result type is returned on the secondary stack or
-- is a tagged type. Tagged primitive build-in-place functions need
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 3867270e71a9..5919627a4e7e 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -301,8 +301,10 @@ package Exp_Ch6 is
-- BIP_Alloc_Form parameter (see type BIP_Formal_Kind).
function Needs_BIP_Collection (Func_Id : Entity_Id) return Boolean;
- -- Ada 2005 (AI-318-02): Return True if the function needs an implicit
- -- BIP_Collection parameter (see type BIP_Formal_Kind).
+ -- Ada 2005 (AI-318-02): Return True if the result subtype of function
+ -- Func_Id might need finalization actions. This includes build-in-place
+ -- functions with tagged result types, since they can be invoked via
+ -- dispatching calls, and descendant types may require finalization.
function Needs_BIP_Task_Actuals (Func_Id : Entity_Id) return Boolean;
-- Return True if the function returns an object of a type that has tasks.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index d60c6edecdff..62e9d2cbb73f 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -4758,18 +4758,18 @@ package body Exp_Ch7 is
-- We mark the secondary stack if it is used in this construct, and
-- we're not returning a function result on the secondary stack, except
- -- that a build-in-place function that only conditionally returns on
- -- the secondary stack will also need a mark. A run-time test for doing
- -- the release call is needed in the case where the build-in-place
- -- function has a BIP_Alloc_Form parameter (see Create_Finalizer).
+ -- that a build-in-place function that might or might not return on the
+ -- secondary stack always needs a mark. A run-time test is required in
+ -- the case where the build-in-place function has a BIP_Alloc extra
+ -- parameter (see Create_Finalizer).
Needs_Sec_Stack_Mark : constant Boolean :=
- Uses_Sec_Stack (Scop)
- and then
- (not Sec_Stack_Needed_For_Return (Scop)
- or else
- (Is_Build_In_Place_Function (Scop)
- and then Needs_BIP_Alloc_Form (Scop)));
+ (Uses_Sec_Stack (Scop)
+ and then
+ not Sec_Stack_Needed_For_Return (Scop))
+ or else
+ (Is_Build_In_Place_Function (Scop)
+ and then Needs_BIP_Alloc_Form (Scop));
Needs_Custom_Cleanup : constant Boolean :=
Nkind (N) = N_Block_Statement
--
2.43.0
