From 6a4f3b312e2aa6016963a6befc986b93465be968 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 17 Jul 2018 08:03:44 +0000 Subject: [PATCH] [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. 2018-07-17 Hristian Kirtchev 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. From-SVN: r262766 --- gcc/ada/ChangeLog | 14 ++++++++ gcc/ada/exp_ch6.adb | 27 ++++++++++++--- gcc/ada/sem_util.adb | 37 +++++++++++++-------- gcc/ada/sem_util.ads | 15 ++++++--- gcc/testsuite/ChangeLog | 4 +++ gcc/testsuite/gnat.dg/bip_case_expr.adb | 15 +++++++++ gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads | 7 ++++ 7 files changed, 96 insertions(+), 23 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/bip_case_expr.adb create mode 100644 gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4e7eba7da0f..d6cf6e78a88 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2018-07-17 Hristian Kirtchev + + * 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. + 2018-07-17 Arnaud Charlet * doc/gnat_ugn/about_this_guide.rst, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 9ddf0fa0381..ef6406d203e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1c3610c3251..c8c914a093b 100644 --- a/gcc/ada/sem_util.adb +++ b/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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9bff3ba92cf..34d618e6400 100644 --- a/gcc/ada/sem_util.ads +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a6cd3c80d1a..c801b103c82 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-07-17 Hristian Kirtchev + + * gnat.dg/bip_case_expr.adb, gnat.dg/bip_case_expr_pkg.ads: New testcase. + 2018-07-16 Carl Love PR target/86414 diff --git a/gcc/testsuite/gnat.dg/bip_case_expr.adb b/gcc/testsuite/gnat.dg/bip_case_expr.adb new file mode 100644 index 00000000000..6e8a6875f15 --- /dev/null +++ b/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; diff --git a/gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads b/gcc/testsuite/gnat.dg/bip_case_expr_pkg.ads new file mode 100644 index 00000000000..3fb00092b4e --- /dev/null +++ b/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; -- 2.30.2