From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id E21CE3A19016 for ; Thu, 29 Apr 2021 08:03:51 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org E21CE3A19016 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C22E9561AC; Thu, 29 Apr 2021 04:03:47 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id zYm-PiEKZGcc; Thu, 29 Apr 2021 04:03:47 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id AF231561B9; Thu, 29 Apr 2021 04:03:47 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id AE6F5193; Thu, 29 Apr 2021 04:03:47 -0400 (EDT) Date: Thu, 29 Apr 2021 04:03:47 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Arnaud Charlet Subject: [Ada] Bad handling of array sliding in aggregate Message-ID: <20210429080347.GA133950@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="BOKacYhQ+x31HxR3" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Thu, 29 Apr 2021 08:03:55 -0000 --BOKacYhQ+x31HxR3 Content-Type: text/plain; charset=us-ascii Content-Disposition: inline In the case of an aggregate containing controlled array components, if sliding of the indexes is involved, the components are prematurely finalized without a corresponding initialization. Also fix a latent bug in Exp_Aggr.Collect_Initialization_Statements which was not always inserting Initialization_Statements properly when the Node_After was empty (in the case of e.g. a single object declaration). This is needed in order to take advantage of Initialization_Statements in Expand_N_Object_Declaration: we scan Initialization_Statements and if a call to xxxSA is found, it means we need to initialize the corresponding array component before it gets prematurely adjusted. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * exp_aggr.adb (Collect_Initialization_Statements): Removed. (Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix creation and insertion of Initialization_Statements. Do not set Initialization_Statements when a transient scope is involved. Move processing of Array_Slice here. Ensure that an object with an Array_Slice call gets its array component initialized. Add comments. * exp_ch7.adb: Update comments. (Store_Actions_In_Scope): Deal properly with an empty list which might now be generated by Convert_Aggr_In_Object_Decl. * exp_ch3.adb: Update comments. (Expand_N_Object_Declaration): Remove processing of Array_Slice. --BOKacYhQ+x31HxR3 Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -78,15 +78,6 @@ package body Exp_Aggr is type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id); - -- If Obj is not frozen, collect actions inserted after N until, but not - -- including, Node_After, for initialization of Obj, and move them to an - -- expression with actions, which becomes the Initialization_Statements for - -- Obj. - procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Container_Aggregate (N : Node_Id); @@ -4210,40 +4201,6 @@ package body Exp_Aggr is return L; end Build_Record_Aggr_Code; - --------------------------------------- - -- Collect_Initialization_Statements -- - --------------------------------------- - - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Init_Actions : constant List_Id := New_List; - Init_Node : Node_Id; - Comp_Stmt : Node_Id; - - begin - -- Nothing to do if Obj is already frozen, as in this case we known we - -- won't need to move the initialization statements about later on. - - if Is_Frozen (Obj) then - return; - end if; - - Init_Node := N; - while Next (Init_Node) /= Node_After loop - Append_To (Init_Actions, Remove_Next (Init_Node)); - end loop; - - if not Is_Empty_List (Init_Actions) then - Comp_Stmt := Make_Compound_Statement (Loc, Actions => Init_Actions); - Insert_Action_After (Init_Node, Comp_Stmt); - Set_Initialization_Statements (Obj, Comp_Stmt); - end if; - end Collect_Initialization_Statements; - ------------------------------- -- Convert_Aggr_In_Allocator -- ------------------------------- @@ -4314,6 +4271,8 @@ package body Exp_Aggr is Typ : constant Entity_Id := Etype (Aggr); Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); + Has_Transient_Scope : Boolean := False; + function Discriminants_Ok return Boolean; -- If the object type is constrained, the discriminants in the -- aggregate must be checked against the discriminants of the subtype. @@ -4405,7 +4364,7 @@ package body Exp_Aggr is -- the finalization list of the return must be moved to the caller's -- finalization list to complete the return. - -- However, if the aggregate is limited, it is built in place, and the + -- Similarly if the aggregate is limited, it is built in place, and the -- controlled components are not assigned to intermediate temporaries -- so there is no need for a transient scope in this case either. @@ -4414,13 +4373,60 @@ package body Exp_Aggr is and then not Is_Limited_Type (Typ) then Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False); + Has_Transient_Scope := True; end if; declare - Node_After : constant Node_Id := Next (N); + Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); + Stmt : Node_Id; + Param : Node_Id; + begin - Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); - Collect_Initialization_Statements (Obj, N, Node_After); + -- If Obj is already frozen or if N is wrapped in a transient scope, + -- Stmts do not need to be saved in Initialization_Statements since + -- there is no freezing issue. + + if Is_Frozen (Obj) or else Has_Transient_Scope then + Insert_Actions_After (N, Stmts); + else + Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts); + Insert_Action_After (N, Stmt); + + -- Insert_Action_After may freeze Obj in which case we should + -- remove the compound statement just created and simply insert + -- Stmts after N. + + if Is_Frozen (Obj) then + Remove (Stmt); + Insert_Actions_After (N, Stmts); + else + Set_Initialization_Statements (Obj, Stmt); + end if; + end if; + + -- If Typ has controlled components and a call to a Slice_Assign + -- procedure is part of the initialization statements, then we + -- need to initialize the array component since Slice_Assign will + -- need to adjust it. + + if Has_Controlled_Component (Typ) then + Stmt := First (Stmts); + + while Present (Stmt) loop + if Nkind (Stmt) = N_Procedure_Call_Statement + and then Get_TSS_Name (Entity (Name (Stmt))) + = TSS_Slice_Assign + then + Param := First (Parameter_Associations (Stmt)); + Insert_Actions + (Stmt, + Build_Initialization_Call + (Sloc (N), New_Copy_Tree (Param), Etype (Param))); + end if; + + Next (Stmt); + end loop; + end if; end; Set_No_Initialization (N); @@ -6793,6 +6799,7 @@ package body Exp_Aggr is -- code must be inserted after it. The defining entity might not come -- from source if this is part of an inlined body, but the declaration -- itself will. + -- The test below looks very specialized and kludgy??? if Comes_From_Source (Tmp) or else @@ -6800,18 +6807,18 @@ package body Exp_Aggr is and then Comes_From_Source (Parent (N)) and then Tmp = Defining_Entity (Parent (N))) then - declare - Node_After : constant Node_Id := Next (Parent_Node); - - begin + if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then Insert_Actions_After (Parent_Node, Aggr_Code); - - if Parent_Kind = N_Object_Declaration then - Collect_Initialization_Statements - (Obj => Tmp, N => Parent_Node, Node_After => Node_After); - end if; - end; - + else + declare + Comp_Stmt : constant Node_Id := + Make_Compound_Statement + (Sloc (Parent_Node), Actions => Aggr_Code); + begin + Insert_Action_After (Parent_Node, Comp_Stmt); + Set_Initialization_Statements (Tmp, Comp_Stmt); + end; + end if; else Insert_Actions (N, Aggr_Code); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -124,7 +124,7 @@ package body Exp_Ch3 is -- Build assignment procedure for one-dimensional arrays of controlled -- types. Other array and slice assignments are expanded in-line, but -- the code expansion for controlled components (when control actions - -- are active) can lead to very large blocks that GCC3 handles poorly. + -- are active) can lead to very large blocks that GCC handles poorly. procedure Build_Untagged_Equality (Typ : Entity_Id); -- AI05-0123: Equality on untagged records composes. This procedure @@ -4168,7 +4168,7 @@ package body Exp_Ch3 is -- Generates the following subprogram: - -- procedure Assign + -- procedure array_typeSA -- (Source, Target : Array_Type, -- Left_Lo, Left_Hi : Index; -- Right_Lo, Right_Hi : Index; @@ -4178,7 +4178,6 @@ package body Exp_Ch3 is -- Ri1 : Index; -- begin - -- if Left_Hi < Left_Lo then -- return; -- end if; @@ -4204,7 +4203,7 @@ package body Exp_Ch3 is -- Ri1 := Index'succ (Ri1); -- end if; -- end loop; - -- end Assign; + -- end array_typeSA; procedure Build_Slice_Assignment (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); @@ -6561,7 +6560,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not No_Initialization (N) then Obj_Init := Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + (Obj_Ref => New_Object_Reference, Typ => Typ); end if; @@ -6977,11 +6976,7 @@ package body Exp_Ch3 is else -- Obtain actual expression from qualified expression - if Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; + Expr_Q := Unqualify (Expr); -- When we have the appropriate type of aggregate in the expression -- (it has been determined during analysis of the aggregate by diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -153,9 +153,6 @@ package body Exp_Ch7 is procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope - -- ??? The entire comment needs to be rewritten - -- ??? which entire comment? - procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); -- Shared processing for Store_xxx_Actions_In_Scope @@ -9841,7 +9838,7 @@ package body Exp_Ch7 is Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); begin - if No (Actions) then + if Is_Empty_List (Actions) then Actions := L; if Is_List_Member (SE.Node_To_Be_Wrapped) then --BOKacYhQ+x31HxR3--