From 7782ff677140c37402dc51fa711dff12950bc8c8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 14 Jun 2016 14:33:56 +0200 Subject: [PATCH] [multiple changes] 2016-06-14 Ed Schonberg * contracts.adb (Has_Null_Body): Move to sem_util, for general availability. * sem_util.ads, sem_util.adb (Has_Null_Body): Predicate to determine when an internal procedure created for some assertion checking (e.g. type invariant) is a null procedure. Used to eliminate redundant calls to such procedures when they apply to components of composite types. * exp_ch3.adb (Build_Component_Invariant_Call): Do not add call if invariant procedure has a null body. 2016-06-14 Thomas Quinot * g-socket.ads (Check_Selector): Clarify effect on IN OUT socket set parameters. 2016-06-14 Hristian Kirtchev * exp_ch4.adb (Process_Action): Pass the action list to Process_Transient_Object. (Process_If_Case_Statements): Pass the action list to Process_Transient_Object. (Process_Transient_Object): Add new parameter Stmts and update the comment on usage. When the context is a Boolean evaluation, insert any finalization calls after the last statement of the construct. From-SVN: r237435 --- gcc/ada/ChangeLog | 27 +++++++++++++++++++ gcc/ada/contracts.adb | 63 ------------------------------------------- gcc/ada/exp_ch3.adb | 12 ++++++--- gcc/ada/exp_ch4.adb | 49 +++++++++++++++++++++++++++------ gcc/ada/g-socket.ads | 7 +++-- gcc/ada/sem_util.adb | 59 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 5 ++++ 7 files changed, 146 insertions(+), 76 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 479c7f04887..cedc29835b8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2016-06-14 Ed Schonberg + + * contracts.adb (Has_Null_Body): Move to sem_util, for general + availability. + * sem_util.ads, sem_util.adb (Has_Null_Body): Predicate to + determine when an internal procedure created for some assertion + checking (e.g. type invariant) is a null procedure. Used to + eliminate redundant calls to such procedures when they apply to + components of composite types. + * exp_ch3.adb (Build_Component_Invariant_Call): Do not add call + if invariant procedure has a null body. + +2016-06-14 Thomas Quinot + + * g-socket.ads (Check_Selector): Clarify effect on IN OUT socket + set parameters. + +2016-06-14 Hristian Kirtchev + + * exp_ch4.adb (Process_Action): Pass the action + list to Process_Transient_Object. + (Process_If_Case_Statements): Pass the action list to + Process_Transient_Object. + (Process_Transient_Object): Add new parameter Stmts and update the + comment on usage. When the context is a Boolean evaluation, insert + any finalization calls after the last statement of the construct. + 2016-06-14 Tristan Gingold * einfo.adb, einfo.ads (Has_Timing_Event, diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index f6d236ffe0a..c85b650d66b 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -1452,73 +1452,10 @@ package body Contracts is ------------------------- function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is - function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; - -- Determine whether the body of procedure Proc_Id contains a sole - -- null statement, possibly followed by an optional return. - function Has_Public_Visibility_Of_Subprogram return Boolean; -- Determine whether type Typ has public visibility of subprogram -- Subp_Id. - ------------------- - -- Has_Null_Body -- - ------------------- - - function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is - Body_Id : Entity_Id; - Decl : Node_Id; - Spec : Node_Id; - Stmt1 : Node_Id; - Stmt2 : Node_Id; - - begin - Spec := Parent (Proc_Id); - Decl := Parent (Spec); - - -- Retrieve the entity of the invariant procedure body - - if Nkind (Spec) = N_Procedure_Specification - and then Nkind (Decl) = N_Subprogram_Declaration - then - Body_Id := Corresponding_Body (Decl); - - -- The body acts as a spec - - else - Body_Id := Proc_Id; - end if; - - -- The body will be generated later - - if No (Body_Id) then - return False; - end if; - - Spec := Parent (Body_Id); - Decl := Parent (Spec); - - pragma Assert - (Nkind (Spec) = N_Procedure_Specification - and then Nkind (Decl) = N_Subprogram_Body); - - Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); - - -- Look for a null statement followed by an optional return - -- statement. - - if Nkind (Stmt1) = N_Null_Statement then - Stmt2 := Next (Stmt1); - - if Present (Stmt2) then - return Nkind (Stmt2) = N_Simple_Return_Statement; - else - return True; - end if; - end if; - - return False; - end Has_Null_Body; - ----------------------------------------- -- Has_Public_Visibility_Of_Subprogram -- ----------------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b5074174211..3213b5d56a0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -3714,9 +3714,9 @@ package body Exp_Ch3 is Sel_Comp : Node_Id; Typ : Entity_Id; Call : Node_Id; + Proc : Entity_Id; begin - Invariant_Found := True; Typ := Etype (Comp); Sel_Comp := @@ -3744,10 +3744,16 @@ package body Exp_Ch3 is -- The aspect is type-specific, so retrieve it from the base type + Proc := Invariant_Procedure (Base_Type (Typ)); + + if Has_Null_Body (Proc) then + return Make_Null_Statement (Loc); + end if; + + Invariant_Found := True; Call := Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Invariant_Procedure (Base_Type (Typ)), Loc), + Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => New_List (Sel_Comp)); if Is_Access_Type (Etype (Comp)) then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a48cdab695d..36f3ecc1b00 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -230,13 +230,18 @@ package body Exp_Ch4 is -- generates code to clean them up when the context of the expression is -- evaluated or elaborated. - procedure Process_Transient_Object (Decl : Node_Id; N : Node_Id); + procedure Process_Transient_Object + (Decl : Node_Id; + N : Node_Id; + Stmts : List_Id); -- Subsidiary routine to the expansion of expression_with_actions, if and -- case expressions. Generate all necessary code to finalize a transient -- controlled object when the enclosing context is elaborated or evaluated. -- Decl denotes the declaration of the transient controlled object which is -- usually the result of a controlled function call. N denotes the related - -- expression_with_actions, if expression, or case expression. + -- expression_with_actions, if expression, or case expression node. Stmts + -- denotes the statement list which contains Decl, either at the top level + -- or within a nested construct. procedure Rewrite_Comparison (N : Node_Id); -- If N is the node for a comparison whose outcome can be determined at @@ -4992,7 +4997,7 @@ package body Exp_Ch4 is if Nkind (Act) = N_Object_Declaration and then Is_Finalizable_Transient (Act, N) then - Process_Transient_Object (Act, N); + Process_Transient_Object (Act, N, Acts); return Abandon; -- Avoid processing temporary function results multiple times when @@ -5037,7 +5042,7 @@ package body Exp_Ch4 is -- do not leak to the expression of the expression_with_actions node: -- do - -- Trans_Id : Ctrl_Typ : ...; + -- Trans_Id : Ctrl_Typ := ...; -- Alias : ... := Trans_Id; -- in ... Alias ... end; @@ -5047,7 +5052,7 @@ package body Exp_Ch4 is -- reference to the Alias within the actions list: -- do - -- Trans_Id : Ctrl_Typ : ...; + -- Trans_Id : Ctrl_Typ := ...; -- Alias : ... := Trans_Id; -- Val : constant Boolean := ... Alias ...; -- @@ -12909,7 +12914,7 @@ package body Exp_Ch4 is if Nkind (Decl) = N_Object_Declaration and then Is_Finalizable_Transient (Decl, N) then - Process_Transient_Object (Decl, N); + Process_Transient_Object (Decl, N, Stmts); end if; Next (Decl); @@ -12920,7 +12925,11 @@ package body Exp_Ch4 is -- Process_Transient_Object -- ------------------------------ - procedure Process_Transient_Object (Decl : Node_Id; N : Node_Id) is + procedure Process_Transient_Object + (Decl : Node_Id; + N : Node_Id; + Stmts : List_Id) + is Loc : constant Source_Ptr := Sloc (Decl); Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Obj_Typ : constant Node_Id := Etype (Obj_Id); @@ -12940,8 +12949,32 @@ package body Exp_Ch4 is -- transient controlled object. begin + pragma Assert (Nkind_In (N, N_Case_Expression, + N_Expression_With_Actions, + N_If_Expression)); + + -- When the context is a Boolean evaluation, all three nodes capture the + -- result of their computation in a local temporary: + + -- do + -- Trans_Id : Ctrl_Typ := ...; + -- Result : constant Boolean := ... Trans_Id ...; + -- + -- in Result end; + + -- As a result, the finalization of any transient controlled objects can + -- safely take place after the result capture. + + -- ??? could this be extended to elementary types? + if Is_Boolean_Type (Etype (N)) then - Fin_Context := Last (List_Containing (Decl)); + Fin_Context := Last (Stmts); + + -- Otherwise the immediate context may not be safe enough to carry out + -- transient controlled object finalization due to aliasing and nesting + -- of constructs. Insert calls to [Deep_]Finalize after the innermost + -- enclosing non-transient construct. + else Fin_Context := Hook_Context; end if; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index ff293decd01..5de70d810dc 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2014, AdaCore -- +-- Copyright (C) 2001-2016, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1107,7 +1107,10 @@ package GNAT.Sockets is -- -- Note that two different Socket_Set_Type objects must be passed as -- R_Socket_Set and W_Socket_Set (even if they denote the same set of - -- Sockets), or some event may be lost. + -- Sockets), or some event may be lost. Also keep in mind that this + -- procedure modifies the passed socket sets to indicate which sockets + -- actually had events upon return. The socket set therefore has to + -- be reset by the caller for further calls. -- -- Socket_Error is raised when the select(2) system call returns an error -- condition, or when a read error occurs on the signalling socket used for diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6237d7b5d0c..020e6d739ce 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9581,6 +9581,65 @@ package body Sem_Util is and then Nkind (Node (First_Elmt (Constits))) /= N_Null; end Has_Non_Null_Refinement; + ------------------- + -- Has_Null_Body -- + ------------------- + + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is + Body_Id : Entity_Id; + Decl : Node_Id; + Spec : Node_Id; + Stmt1 : Node_Id; + Stmt2 : Node_Id; + + begin + Spec := Parent (Proc_Id); + Decl := Parent (Spec); + + -- Retrieve the entity of the procedure body (e.g. invariant proc). + + if Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Declaration + then + Body_Id := Corresponding_Body (Decl); + + -- The body acts as a spec + + else + Body_Id := Proc_Id; + end if; + + -- The body will be generated later + + if No (Body_Id) then + return False; + end if; + + Spec := Parent (Body_Id); + Decl := Parent (Spec); + + pragma Assert + (Nkind (Spec) = N_Procedure_Specification + and then Nkind (Decl) = N_Subprogram_Body); + + Stmt1 := First (Statements (Handled_Statement_Sequence (Decl))); + + -- Look for a null statement followed by an optional return + -- statement. + + if Nkind (Stmt1) = N_Null_Statement then + Stmt2 := Next (Stmt1); + + if Present (Stmt2) then + return Nkind (Stmt2) = N_Simple_Return_Statement; + else + return True; + end if; + end if; + + return False; + end Has_Null_Body; + ------------------------ -- Has_Null_Exclusion -- ------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index d0e3d4ee87f..a1e703fbba9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1103,6 +1103,11 @@ package Sem_Util is -- as expressed in pragma Refined_State. This function does not take into -- account the visible refinement region of abstract state Id. + function Has_Null_Body (Proc_Id : Entity_Id) return Boolean; + -- Determine whether the body of procedure Proc_Id contains a sole + -- null statement, possibly followed by an optional return. Used to + -- optimize useless calls to assertion checks. + function Has_Null_Exclusion (N : Node_Id) return Boolean; -- Determine whether node N has a null exclusion -- 2.30.2