[Ada] Fix incorrect itype sharing for case expression in limited type return
Commit Message
The compiler aborts with an internal error in gigi, but the problem is an
itype incorrectly shared between several branches of an if_statement that
has been created for a Build-In-Place return.
Three branches of this if_statement contain an allocator statement and
the latter two have been obtained as the result of calling New_Copy_Tree
on the first; now the initialization expression of the first had also been
obtained as the result of calling New_Copy_Tree on the original tree, and
these chained calls to New_Copy_Tree run afoul of an issue with the copy
of itypes after the rewrite of an aggregate as an expression with actions.
Fixing this issue looks quite delicate, so this fixes the incorrect sharing
by replacing the chained calls to New_Copy_Tree with repeated calls on the
original expression, which is more elegant in any case.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* exp_ch3.adb (Make_Allocator_For_BIP_Return): New local function.
(Expand_N_Object_Declaration): Use it to build the three allocators
for a Build-In-Place return with an unconstrained type. Update the
head comment after other recent changes.
@@ -7980,16 +7980,11 @@ package body Exp_Ch3 is
-- the value one, then the caller has passed access to an
-- existing object for use as the return object. If the value
-- is two, then the return object must be allocated on the
- -- secondary stack. Otherwise, the object must be allocated in
- -- a storage pool. We generate an if statement to test the
- -- implicit allocation formal and initialize a local access
- -- value appropriately, creating allocators in the secondary
- -- stack and global heap cases. The special formal also exists
- -- and must be tested when the function has a tagged result,
- -- even when the result subtype is constrained, because in
- -- general such functions can be called in dispatching contexts
- -- and must be handled similarly to functions with a class-wide
- -- result.
+ -- secondary stack. If the value is three, then the return
+ -- object must be allocated on the heap. Otherwise, the object
+ -- must be allocated in a storage pool. We generate an if
+ -- statement to test the BIP_Alloc_Form formal and initialize
+ -- a local access value appropriately.
if Needs_BIP_Alloc_Form (Func_Id) then
declare
@@ -8005,6 +8000,73 @@ package body Exp_Ch3 is
Pool_Id : constant Entity_Id :=
Make_Temporary (Loc, 'P');
+ function Make_Allocator_For_BIP_Return return Node_Id;
+ -- Make an allocator for the BIP return being processed
+
+ -----------------------------------
+ -- Make_Allocator_For_BIP_Return --
+ -----------------------------------
+
+ function Make_Allocator_For_BIP_Return return Node_Id is
+ Alloc : Node_Id;
+
+ begin
+ if Present (Expr_Q)
+ and then not Is_Delayed_Aggregate (Expr_Q)
+ and then not No_Initialization (N)
+ then
+ -- Always use the type of the expression for the
+ -- qualified expression, rather than the result type.
+ -- In general we cannot always use the result type
+ -- for the allocator, because the expression might be
+ -- of a specific type, such as in the case of an
+ -- aggregate or even a nonlimited object when the
+ -- result type is a limited class-wide interface type.
+
+ Alloc :=
+ Make_Allocator (Loc,
+ Expression =>
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Expr_Q), Loc),
+ Expression => New_Copy_Tree (Expr_Q)));
+
+ else
+ -- If the function returns a class-wide type we cannot
+ -- use the return type for the allocator. Instead we
+ -- use the type of the expression, which must be an
+ -- aggregate of a definite type.
+
+ if Is_Class_Wide_Type (Ret_Obj_Typ) then
+ Alloc :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Etype (Expr_Q), Loc));
+
+ else
+ Alloc :=
+ Make_Allocator (Loc,
+ Expression =>
+ New_Occurrence_Of (Ret_Obj_Typ, Loc));
+ end if;
+
+ -- If the object requires default initialization then
+ -- that will happen later following the elaboration of
+ -- the object renaming. If we don't turn it off here
+ -- then the object will be default initialized twice.
+
+ Set_No_Initialization (Alloc);
+ end if;
+
+ -- Set the flag indicating that the allocator came from
+ -- a build-in-place return statement, so we can avoid
+ -- adjusting the allocated object.
+
+ Set_Alloc_For_BIP_Return (Alloc);
+
+ return Alloc;
+ end Make_Allocator_For_BIP_Return;
+
Alloc_Obj_Id : Entity_Id;
Alloc_Obj_Decl : Node_Id;
Alloc_Stmt : Node_Id;
@@ -8049,71 +8111,15 @@ package body Exp_Ch3 is
Insert_Action (N, Alloc_Obj_Decl);
- -- Create allocators for both the secondary stack and
- -- global heap. If there's an initialization expression,
- -- then create these as initialized allocators.
-
- if Present (Expr_Q)
- and then not Is_Delayed_Aggregate (Expr_Q)
- and then not No_Initialization (N)
- then
- -- Always use the type of the expression for the
- -- qualified expression, rather than the result type.
- -- In general we cannot always use the result type
- -- for the allocator, because the expression might be
- -- of a specific type, such as in the case of an
- -- aggregate or even a nonlimited object when the
- -- result type is a limited class-wide interface type.
-
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Expr_Q), Loc),
- Expression => New_Copy_Tree (Expr_Q)));
-
- else
- -- If the function returns a class-wide type we cannot
- -- use the return type for the allocator. Instead we
- -- use the type of the expression, which must be an
- -- aggregate of a definite type.
+ -- First create the Heap_Allocator
- if Is_Class_Wide_Type (Ret_Obj_Typ) then
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of (Etype (Expr_Q), Loc));
-
- else
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of (Ret_Obj_Typ, Loc));
- end if;
-
- -- If the object requires default initialization then
- -- that will happen later following the elaboration of
- -- the object renaming. If we don't turn it off here
- -- then the object will be default initialized twice.
-
- Set_No_Initialization (Heap_Allocator);
- end if;
-
- -- Set the flag indicating that the allocator came from
- -- a build-in-place return statement, so we can avoid
- -- adjusting the allocated object. Note that this flag
- -- will be inherited by the copies made below.
-
- Set_Alloc_For_BIP_Return (Heap_Allocator);
+ Heap_Allocator := Make_Allocator_For_BIP_Return;
-- The Pool_Allocator is just like the Heap_Allocator,
-- except we set Storage_Pool and Procedure_To_Call so
-- it will use the user-defined storage pool.
- Pool_Allocator := New_Copy_Tree (Heap_Allocator);
-
- pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
+ Pool_Allocator := Make_Allocator_For_BIP_Return;
-- Do not generate the renaming of the build-in-place
-- pool parameter on ZFP because the parameter is not
@@ -8154,9 +8160,7 @@ package body Exp_Ch3 is
-- allocation.
else
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
-
- pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
+ SS_Allocator := Make_Allocator_For_BIP_Return;
-- The heap and pool allocators are marked as
-- Comes_From_Source since they correspond to an