From: Arnaud Charlet Date: Tue, 25 Apr 2017 10:03:40 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=89b6c83e251d0b65860be2353fcf261169af2cf3;p=gcc.git [multiple changes] 2017-04-25 Hristian Kirtchev * checks.adb (Insert_Valid_Check): Partially reimplement validity checks. * einfo.adb Node36 is now used as Validated_Object. (Validated_Object): New routine. (Set_Validated_Object): New routine. (Write_Field36_Name): Add an entry for Validated_Object. * einfo.ads Add new attribute Validated_Object along with usage in entities. (Validated_Object): New routine along with pragma Inline. (Set_Validated_Object): New routine along with pragma Inline. * exp_attr.adb (Make_Range_Test): Add processing for validation variables to avoid extra reads and copies of the prefix. * exp_ch6.adb (Expand_Actuals): Add copy-back for validation variables in order to reflect any changes done in the variable back into the original object. * sem_util.adb (Is_Validation_Variable_Reference): New routine. * sem_util.ads (Is_Validation_Variable_Reference): New routine. 2017-04-25 Steve Baird * exp_ch7.adb (Build_Array_Deep_Procs, Build_Record_Deep_Procs, Make_Finalize_Address_Body): Don't generate Finalize_Address routines for CodePeer. 2017-04-25 Ed Schonberg * sem_prag.adb (Inherits_Class_Wide_Pre): subsidiary of Analyze_Pre_Post_Condition, to implement the legality checks mandated by AI12-0131: Pre'Class shall not be specified for an overriding primitive subprogram of a tagged type T unless the Pre'Class aspect is specified for the corresponding primitive subprogram of some ancestor of T. From-SVN: r247170 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9f06f0cd210..07615147138 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2017-04-25 Hristian Kirtchev + + * checks.adb (Insert_Valid_Check): Partially reimplement validity + checks. + * einfo.adb Node36 is now used as Validated_Object. + (Validated_Object): New routine. + (Set_Validated_Object): New routine. + (Write_Field36_Name): Add an entry for Validated_Object. + * einfo.ads Add new attribute Validated_Object along with + usage in entities. + (Validated_Object): New routine along with pragma Inline. + (Set_Validated_Object): New routine along with pragma Inline. + * exp_attr.adb (Make_Range_Test): Add processing for validation + variables to avoid extra reads and copies of the prefix. + * exp_ch6.adb (Expand_Actuals): Add copy-back for validation + variables in order to reflect any changes done in the variable + back into the original object. + * sem_util.adb (Is_Validation_Variable_Reference): New routine. + * sem_util.ads (Is_Validation_Variable_Reference): New routine. + +2017-04-25 Steve Baird + + * exp_ch7.adb (Build_Array_Deep_Procs, + Build_Record_Deep_Procs, Make_Finalize_Address_Body): Don't + generate Finalize_Address routines for CodePeer. + +2017-04-25 Ed Schonberg + + * sem_prag.adb (Inherits_Class_Wide_Pre): subsidiary of + Analyze_Pre_Post_Condition, to implement the legality checks + mandated by AI12-0131: Pre'Class shall not be specified for an + overriding primitive subprogram of a tagged type T unless the + Pre'Class aspect is specified for the corresponding primitive + subprogram of some ancestor of T. + 2017-04-25 Bob Duff * sem_ch8.adb (Use_One_Type): If a use_type_clause diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 40d3f3cefd7..ece2f367c16 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7180,51 +7180,92 @@ package body Checks is Exp := Expression (Exp); end loop; + -- Do not generate a check for a variable which already validates the + -- value of an assignable object. + + if Is_Validation_Variable_Reference (Exp) then + return; + end if; + -- We are about to insert the validity check for Exp. We save and -- reset the Do_Range_Check flag over this validity check, and then -- put it back for the final original reference (Exp may be rewritten). declare DRC : constant Boolean := Do_Range_Check (Exp); - PV : Node_Id; CE : Node_Id; + Obj : Node_Id; + PV : Node_Id; + Var : Entity_Id; begin Set_Do_Range_Check (Exp, False); - -- Force evaluation to avoid multiple reads for atomic/volatile + -- If the expression denotes an assignable object, capture its value + -- in a variable and replace the original expression by the variable. + -- This approach has several effects: - -- Note: we set Name_Req to False. We used to set it to True, with - -- the thinking that a name is required as the prefix of the 'Valid - -- call, but in fact the check that the prefix of an attribute is - -- a name is in the parser, and we just don't require it here. - -- Moreover, when we set Name_Req to True, that interfered with the - -- checking for Volatile, since we couldn't just capture the value. + -- 1) The evaluation of the object results in only one read in the + -- case where the object is atomic or volatile. - if Is_Entity_Name (Exp) - and then Is_Volatile (Entity (Exp)) - then - -- Same reasoning as above for setting Name_Req to False + -- Temp ... := Object; -- read - Force_Evaluation (Exp, Name_Req => False); - end if; + -- 2) The captured value is the one verified by attribute 'Valid. + -- As a result the object is not evaluated again, which would + -- result in an unwanted read in the case where the object is + -- atomic or volatile. + + -- if not Temp'Valid then -- OK, no read of Object + + -- if not Object'Valid then -- Wrong, extra read of Object + + -- 3) The captured value replaces the original object reference. + -- As a result the object is not evaluated again, in the same + -- vein as 2). + + -- ... Temp ... -- OK, no read of Object + + -- ... Object ... -- Wrong, extra read of Object - -- Build the prefix for the 'Valid call. If the expression denotes - -- a non-volatile name, use a renaming to alias it, otherwise use a - -- constant to capture the value of the expression. - - -- Temp : ... renames Expr; -- non-volatile name - -- Temp : constant ... := Expr; -- all other cases - - PV := - Duplicate_Subexpr_No_Checks - (Exp => Exp, - Name_Req => False, - Renaming_Req => - Is_Name_Reference (Exp) and then not Is_Volatile (Typ), - Related_Id => Related_Id, - Is_Low_Bound => Is_Low_Bound, - Is_High_Bound => Is_High_Bound); + -- 4) The use of a variable to capture the value of the object + -- allows the propagation of any changes back to the original + -- object. + + -- procedure Call (Val : in out ...); + + -- Temp : ... := Object; -- read Object + -- if not Temp'Valid then -- validity check + -- Call (Temp); -- modify Temp + -- Object := Temp; -- update Object + + if Is_Variable (Exp) then + Obj := New_Copy_Tree (Exp); + Var := Make_Temporary (Loc, 'T', Exp); + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Var, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (Exp))); + Set_Validated_Object (Var, Obj); + + Rewrite (Exp, New_Occurrence_Of (Var, Loc)); + PV := New_Occurrence_Of (Var, Loc); + + -- Otherwise the expression does not denote a variable. Force its + -- evaluation by capturing its value in a constant. Generate: + + -- Temp : constant ... := Exp; + + else + Force_Evaluation + (Exp => Exp, + Related_Id => Related_Id, + Is_Low_Bound => Is_Low_Bound, + Is_High_Bound => Is_High_Bound); + + PV := New_Copy_Tree (Exp); + end if; -- A rather specialized test. If PV is an analyzed expression which -- is an indexed component of a packed array that has not been diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 441d3096264..26e42243215 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -270,6 +270,8 @@ package body Einfo is -- Entry_Max_Queue_Lengths_Array Node35 -- Import_Pragma Node35 + -- Validated_Object Node36 + -- Class_Wide_Preconds List38 -- Class_Wide_Postconds List39 @@ -3477,6 +3479,12 @@ package body Einfo is return Flag95 (Id); end Uses_Sec_Stack; + function Validated_Object (Id : E) return N is + begin + pragma Assert (Ekind (Id) = E_Variable); + return Node36 (Id); + end Validated_Object; + function Warnings_Off (Id : E) return B is begin return Flag96 (Id); @@ -6618,6 +6626,12 @@ package body Einfo is Set_Flag95 (Id, V); end Set_Uses_Sec_Stack; + procedure Set_Validated_Object (Id : E; V : N) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Node36 (Id, V); + end Set_Validated_Object; + procedure Set_Warnings_Off (Id : E; V : B := True) is begin Set_Flag96 (Id, V); @@ -10881,9 +10895,14 @@ package body Einfo is ------------------------ procedure Write_Field36_Name (Id : Entity_Id) is - pragma Unreferenced (Id); begin - Write_Str ("Field36??"); + case Ekind (Id) is + when E_Variable => + Write_Str ("Validated_Object"); + + when others => + Write_Str ("Field36??"); + end case; end Write_Field36_Name; ------------------------ diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 59990185489..095ec60edeb 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4514,6 +4514,10 @@ package Einfo is -- task). Set to True when secondary stack is used in this scope and must -- be released on exit unless Sec_Stack_Needed_For_Return is set. +-- Validated_Object (Node36) +-- Defined in variables. Contains the object whose value is captured by +-- the variable for validity check purposes. + -- Warnings_Off (Flag96) -- Defined in all entities. Set if a pragma Warnings (Off, entity-name) -- is used to suppress warnings for a given entity. It is also used by @@ -6609,6 +6613,7 @@ package Einfo is -- Linker_Section_Pragma (Node33) -- Contract (Node34) -- Anonymous_Designated_Type (Node35) + -- Validated_Object (Node36) -- SPARK_Pragma (Node40) -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) @@ -7342,6 +7347,7 @@ package Einfo is function Used_As_Generic_Actual (Id : E) return B; function Uses_Lock_Free (Id : E) return B; function Uses_Sec_Stack (Id : E) return B; + function Validated_Object (Id : E) return N; function Warnings_Off (Id : E) return B; function Warnings_Off_Used (Id : E) return B; function Warnings_Off_Used_Unmodified (Id : E) return B; @@ -8029,6 +8035,7 @@ package Einfo is procedure Set_Used_As_Generic_Actual (Id : E; V : B := True); procedure Set_Uses_Lock_Free (Id : E; V : B := True); procedure Set_Uses_Sec_Stack (Id : E; V : B := True); + procedure Set_Validated_Object (Id : E; V : N); procedure Set_Warnings_Off (Id : E; V : B := True); procedure Set_Warnings_Off_Used (Id : E; V : B := True); procedure Set_Warnings_Off_Used_Unmodified (Id : E; V : B := True); @@ -8871,6 +8878,7 @@ package Einfo is pragma Inline (Used_As_Generic_Actual); pragma Inline (Uses_Lock_Free); pragma Inline (Uses_Sec_Stack); + pragma Inline (Validated_Object); pragma Inline (Warnings_Off); pragma Inline (Warnings_Off_Used); pragma Inline (Warnings_Off_Used_Unmodified); @@ -9346,6 +9354,7 @@ package Einfo is pragma Inline (Set_Used_As_Generic_Actual); pragma Inline (Set_Uses_Lock_Free); pragma Inline (Set_Uses_Sec_Stack); + pragma Inline (Set_Validated_Object); pragma Inline (Set_Warnings_Off); pragma Inline (Set_Warnings_Off_Used); pragma Inline (Set_Warnings_Off_Used_Unmodified); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 6061f720517..c1bda8f0442 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6488,32 +6488,48 @@ package body Exp_Attr is --------------------- function Make_Range_Test return Node_Id is - Temp : constant Node_Id := Duplicate_Subexpr (Pref); + Temp : Node_Id; begin - -- The value whose validity is being checked has been captured in - -- an object declaration. We certainly don't want this object to - -- appear valid because the declaration initializes it. + -- The prefix of attribute 'Valid should always denote an object + -- reference. The reference is either coming directly from source + -- or is produced by validity check expansion. - if Is_Entity_Name (Temp) then - Set_Is_Known_Valid (Entity (Temp), False); + -- If the prefix denotes a variable which captures the value of + -- an object for validation purposes, use the variable in the + -- range test. This ensures that no extra copies or extra reads + -- are produced as part of the test. Generate: + + -- Temp : ... := Object; + -- if not Temp in ... then + + if Is_Validation_Variable_Reference (Pref) then + Temp := New_Occurrence_Of (Entity (Pref), Loc); + + -- Otherwise the prefix is either a source object or a constant + -- produced by validity check expansion. Generate: + + -- Temp : constant ... := Pref; + -- if not Temp in ... then + + else + Temp := Duplicate_Subexpr (Pref); end if; return Make_In (Loc, - Left_Opnd => - Unchecked_Convert_To (Btyp, Temp), + Left_Opnd => Unchecked_Convert_To (Btyp, Temp), Right_Opnd => Make_Range (Loc, - Low_Bound => + Low_Bound => Unchecked_Convert_To (Btyp, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_First)), High_Bound => Unchecked_Convert_To (Btyp, Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), + Prefix => New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Last)))); end Make_Range_Test; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c6b235cffaa..e44518f9a7b 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1901,6 +1901,21 @@ package body Exp_Ch6 is then Add_Call_By_Copy_Code; + -- The actual denotes a variable which captures the value of an + -- object for validation purposes. Add a copy-back to reflect any + -- potential changes in value back into the original object. + + -- Temp : ... := Object; + -- if not Temp'Valid then ... + -- Call (Temp); + -- Object := Temp; + + elsif Is_Validation_Variable_Reference (Actual) then + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Validated_Object (Entity (Actual)), + Expression => New_Occurrence_Of (Entity (Actual), Loc))); + elsif Nkind (Actual) = N_Indexed_Component and then Is_Entity_Name (Prefix (Actual)) and then Has_Volatile_Components (Entity (Prefix (Actual))) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a3082e28b19..4febff09c48 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -787,13 +787,15 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address. + -- Create TSS primitive Finalize_Address (unless CodePeer_Mode). - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Array_Body (Address_Case, Typ))); + if not CodePeer_Mode then + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Array_Body (Address_Case, Typ))); + end if; end if; end Build_Array_Deep_Procs; @@ -3669,13 +3671,15 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); - -- Create TSS primitive Finalize_Address + -- Create TSS primitive Finalize_Address (unless CodePeer_Mode). - Set_TSS (Typ, - Make_Deep_Proc - (Prim => Address_Case, - Typ => Typ, - Stmts => Make_Deep_Record_Body (Address_Case, Typ))); + if not CodePeer_Mode then + Set_TSS (Typ, + Make_Deep_Proc + (Prim => Address_Case, + Typ => Typ, + Stmts => Make_Deep_Record_Body (Address_Case, Typ))); + end if; end if; end Build_Record_Deep_Procs; @@ -7797,6 +7801,11 @@ package body Exp_Ch7 is return; end if; + -- Don't generate Finalize_Address routine for CodePeer + if CodePeer_Mode then + return; + end if; + Proc_Id := Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Finalize_Address)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 77fc34b47c4..fee1bb321d6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4208,6 +4208,85 @@ package body Sem_Prag is -- Flag set when the pragma is one of Pre, Pre_Class, Post or -- Post_Class. + function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean; + -- Implement rules in AI12-0131: an overriding operation can have + -- a class-wide precondition only if one of its ancestors has an + -- explicit class-wide precondition. + + ----------------------------- + -- Inherits_Class_Wide_Pre -- + ----------------------------- + + function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is + Prev : Entity_Id := Overridden_Operation (E); + Cont : Node_Id; + Prag : Node_Id; + Typ : Entity_Id; + + begin + -- Check ancestors on the overriding operation to examine the + -- preconditions that may apply to them. + + while Present (Prev) loop + Cont := Contract (Prev); + if Present (Cont) then + Prag := Pre_Post_Conditions (Cont); + while Present (Prag) loop + if Class_Present (Prag) then + return True; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + Prev := Overridden_Operation (Prev); + end loop; + + -- If the controlling type of the subprogram has progenitors, + -- an interface operation implemented by the current operation + -- may have a class-wide precondition. + + Typ := Find_Dispatching_Type (E); + if Has_Interfaces (Typ) then + declare + Ints : Elist_Id; + Elmt : Elmt_Id; + Prim_List : Elist_Id; + Prim_Elmt : Elmt_Id; + Prim : Entity_Id; + begin + Collect_Interfaces (Typ, Ints); + Elmt := First_Elmt (Ints); + + -- Iterate over the primitive operations of each + -- interface. + + while Present (Elmt) loop + Prim_List := + (Direct_Primitive_Operations (Node (Elmt))); + Prim_Elmt := First_Elmt (Prim_List); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + if Chars (Prim) = Chars (E) + and then Present (Contract (Prim)) + and then Class_Present + (Pre_Post_Conditions (Contract (Prim))) + then + return True; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + return False; + end Inherits_Class_Wide_Pre; + begin -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to -- offer uniformity among the various kinds of pre/postconditions by @@ -4326,6 +4405,43 @@ package body Sem_Prag is Error_Pragma ("aspect % requires ''Class for null procedure"); end if; + -- Implement the legality checks mandated by AI12-0131: + -- Pre'Class shall not be specified for an overriding primitive + -- subprogram of a tagged type T unless the Pre'Class aspect is + -- specified for the corresponding primitive subprogram of some + -- ancestor of T. + + declare + E : constant Entity_Id := Defining_Entity (Subp_Decl); + H : constant Entity_Id := Homonym (E); + + begin + if Class_Present (N) + and then Present (Overridden_Operation (E)) + and then not Inherits_Class_Wide_Pre (E) + then + Error_Msg_N + ("illegal class-wide precondition on overriding " + & "operation", Corresponding_Aspect (N)); + + -- If the operation is declared in the private part of an + -- instance it may not override any visible operations, but + -- still have a parent operation that carries a precondition. + + elsif In_Instance + and then In_Private_Part (Current_Scope) + and then Present (H) + and then Scope (E) = Scope (H) + and then Is_Inherited_Operation (H) + and then Present (Overridden_Operation (H)) + and then not Inherits_Class_Wide_Pre (H) + then + Error_Msg_N + ("illegal class-wide precondition on overriding " + & "operation in instance", Corresponding_Aspect (N)); + end if; + end; + -- Otherwise the placement is illegal else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0db7f0f847f..4bbaf1bda66 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -15277,6 +15277,19 @@ package body Sem_Util is return T = Universal_Integer or else T = Universal_Real; end Is_Universal_Numeric_Type; + -------------------------------------- + -- Is_Validation_Variable_Reference -- + -------------------------------------- + + function Is_Validation_Variable_Reference (N : Node_Id) return Boolean is + begin + return + Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Present (Validated_Object (Entity (N))); + end Is_Validation_Variable_Reference; + ---------------------------- -- Is_Variable_Size_Array -- ---------------------------- @@ -15643,7 +15656,6 @@ package body Sem_Util is ------------------------ function Is_Volatile_Object (N : Node_Id) return Boolean is - function Is_Volatile_Prefix (N : Node_Id) return Boolean; -- If prefix is an implicit dereference, examine designated type diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9b4ba0e118b..e3afc1bec0a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1786,6 +1786,10 @@ package Sem_Util is pragma Inline (Is_Universal_Numeric_Type); -- True if T is Universal_Integer or Universal_Real + function Is_Validation_Variable_Reference (N : Node_Id) return Boolean; + -- Determine whether N denotes a reference to a variable which captures the + -- value of an object for validation purposes. + function Is_Variable_Size_Array (E : Entity_Id) return Boolean; -- Returns true if E has variable size components