This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Ada] Crash on case expression in build-in-place function
- From: Pierre-Marie de Rodat <derodat at adacore dot com>
- To: gcc-patches at gcc dot gnu dot org
- Cc: Hristian Kirtchev <kirtchev at adacore dot com>
- Date: Tue, 17 Jul 2018 04:21:36 -0400
- Subject: [Ada] Crash on case expression in build-in-place function
This patch modifies the recursive tree replication routine New_Copy_Tree to
create new entities and remap old entities to the new ones for constructs in
N_Expression_With_Actions nodes when requested by a caller. This in turn allows
the build-in-place mechanism to avoid sharing entities between the 4 variants
of returns it generates.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-17 Hristian Kirtchev <kirtchev@adacore.com>
gcc/ada/
* exp_ch6.adb (Build_Heap_Or_Pool_Allocator): Ensure that scoping
constructs and entities within receive new entities when replicating a
tree.
(Expand_N_Extended_Return_Statement): Ensure that scoping constructs
and entities within receive new entities when replicating a tree.
* sem_util.adb (New_Copy_Tree): Add new formal Scopes_In_EWA_OK.
(Visit_Entity): Visit entities within scoping constructs inside
expression with actions nodes when requested by the caller. Add blocks,
labels, and procedures to the list of entities which need replication.
* sem_util.ads (New_Copy_Tree): Add new formal Scopes_In_EWA_OK. Update
the comment on usage.
gcc/testsuite/
* gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase.
--- gcc/ada/exp_ch6.adb
+++ gcc/ada/exp_ch6.adb
@@ -4562,7 +4562,10 @@ package body Exp_Ch6 is
Fin_Mas_Id : constant Entity_Id :=
Build_In_Place_Formal
(Func_Id, BIP_Finalization_Master);
- Orig_Expr : constant Node_Id := New_Copy_Tree (Alloc_Expr);
+ Orig_Expr : constant Node_Id :=
+ New_Copy_Tree
+ (Source => Alloc_Expr,
+ Scopes_In_EWA_OK => True);
Stmts : constant List_Id := New_List;
Desig_Typ : Entity_Id;
Local_Id : Entity_Id;
@@ -5022,7 +5025,10 @@ package body Exp_Ch6 is
Init_Assignment :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ret_Obj_Id, Loc),
- Expression => New_Copy_Tree (Ret_Obj_Expr));
+ Expression =>
+ New_Copy_Tree
+ (Source => Ret_Obj_Expr,
+ Scopes_In_EWA_OK => True));
Set_Etype (Name (Init_Assignment), Etype (Ret_Obj_Id));
Set_Assignment_OK (Name (Init_Assignment));
@@ -5153,7 +5159,10 @@ package body Exp_Ch6 is
Subtype_Mark =>
New_Occurrence_Of
(Etype (Ret_Obj_Expr), Loc),
- Expression => New_Copy_Tree (Ret_Obj_Expr)));
+ Expression =>
+ New_Copy_Tree
+ (Source => Ret_Obj_Expr,
+ Scopes_In_EWA_OK => True)));
else
-- If the function returns a class-wide type we cannot
@@ -5193,7 +5202,11 @@ package body Exp_Ch6 is
-- 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);
+ Pool_Allocator :=
+ New_Copy_Tree
+ (Source => Heap_Allocator,
+ Scopes_In_EWA_OK => True);
+
pragma Assert (Alloc_For_BIP_Return (Pool_Allocator));
-- Do not generate the renaming of the build-in-place
@@ -5235,7 +5248,11 @@ package body Exp_Ch6 is
-- allocation.
else
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
+ SS_Allocator :=
+ New_Copy_Tree
+ (Source => Heap_Allocator,
+ Scopes_In_EWA_OK => True);
+
pragma Assert (Alloc_For_BIP_Return (SS_Allocator));
-- The heap and pool allocators are marked as
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -19505,10 +19505,11 @@ package body Sem_Util is
-------------------
function New_Copy_Tree
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty;
+ Scopes_In_EWA_OK : Boolean := False) return Node_Id
is
-- This routine performs low-level tree manipulations and needs access
-- to the internals of the tree.
@@ -20430,34 +20431,44 @@ package body Sem_Util is
pragma Assert (Nkind (Id) in N_Entity);
pragma Assert (not Is_Itype (Id));
- -- Nothing to do if the entity is not defined in the Actions list of
- -- an N_Expression_With_Actions node.
+ -- Nothing to do when the entity is not defined in the Actions list
+ -- of an N_Expression_With_Actions node.
if EWA_Level = 0 then
return;
- -- Nothing to do if the entity is defined within a scoping construct
- -- of an N_Expression_With_Actions node.
+ -- Nothing to do when the entity is defined in a scoping construct
+ -- within an N_Expression_With_Actions node, unless the caller has
+ -- requested their replication.
- elsif EWA_Inner_Scope_Level > 0 then
+ -- ??? should this restriction be eliminated?
+
+ elsif EWA_Inner_Scope_Level > 0 and then not Scopes_In_EWA_OK then
return;
- -- Nothing to do if the entity is not an object or a type. Relaxing
+ -- Nothing to do when the entity does not denote a construct that
+ -- may appear within an N_Expression_With_Actions node. Relaxing
-- this restriction leads to a performance penalty.
- elsif not Ekind_In (Id, E_Constant, E_Variable)
+ -- ??? this list is flaky, and may hide dormant bugs
+
+ elsif not Ekind_In (Id, E_Block,
+ E_Constant,
+ E_Label,
+ E_Procedure,
+ E_Variable)
and then not Is_Type (Id)
then
return;
- -- Nothing to do if the entity was already visited
+ -- Nothing to do when the entity was already visited
elsif NCT_Tables_In_Use
and then Present (NCT_New_Entities.Get (Id))
then
return;
- -- Nothing to do if the declaration node of the entity is not within
+ -- Nothing to do when the declaration node of the entity is not in
-- the subtree being replicated.
elsif not In_Subtree
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -872,7 +872,7 @@ package Sem_Util is
Placement : out State_Space_Kind;
Pack_Id : out Entity_Id);
-- Determine the state space placement of an item. Item_Id denotes the
- -- entity of an abstract state, object or package instantiation. Placement
+ -- entity of an abstract state, object, or package instantiation. Placement
-- captures the precise placement of the item in the enclosing state space.
-- If the state space is that of a package, Pack_Id denotes its entity,
-- otherwise Pack_Id is Empty.
@@ -2240,10 +2240,11 @@ package Sem_Util is
-- nodes (entities) either directly or indirectly using this function.
function New_Copy_Tree
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id;
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty;
+ Scopes_In_EWA_OK : Boolean := False) return Node_Id;
-- Perform a deep copy of the subtree rooted at Source. Entities, itypes,
-- and nodes are handled separately as follows:
--
@@ -2313,6 +2314,10 @@ package Sem_Util is
--
-- Parameter New_Scope may be used to specify a new scope for all copied
-- entities and itypes.
+ --
+ -- Parameter Scopes_In_EWA_OK may be used to force the replication of both
+ -- scoping entities and non-scoping entities found within expression with
+ -- actions nodes.
function New_External_Entity
(Kind : Entity_Kind;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bip_case_expr.adb
@@ -0,0 +1,15 @@
+-- { dg-do compile }
+
+with BIP_Case_Expr_Pkg; use BIP_Case_Expr_Pkg;
+
+procedure BIP_Case_Expr is
+ function Make_Any_Lim_Ctrl (Flag : Boolean) return Lim_Ctrl is
+ begin
+ return (case Flag is
+ when True => Make_Lim_Ctrl,
+ when False => Make_Lim_Ctrl);
+ end;
+
+ Res : Lim_Ctrl := Make_Any_Lim_Ctrl (True);
+
+begin null; end BIP_Case_Expr;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads
@@ -0,0 +1,7 @@
+with Ada.Finalization; use Ada.Finalization;
+
+package BIP_Case_Expr_Pkg is
+ type Lim_Ctrl is new Limited_Controlled with null record;
+
+ function Make_Lim_Ctrl return Lim_Ctrl;
+end BIP_Case_Expr_Pkg;