From a187206c1450fc02d7a466b372c073b67f41c26b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 10:07:38 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Tristan Gingold * s-mmap.ads (Data): Add pragma Inline. 2017-04-25 Hristian Kirtchev * checks.adb (Insert_Valid_Check): Do not use a renaming to alias a volatile name because this will lead to multiple evaluations of the volatile name. Use a constant to capture the value instead. 2017-04-25 Doug Rupp * init.c [VxWorks Section]: Disable sigtramp for ppc64-vx7. 2017-04-25 Ed Schonberg * exp_util.adb, exp_util.ads (Build_Class_Wide_Expression): Add out parameter to indicate to caller that a wrapper must be constructed for an inherited primitive whose inherited pre/postcondition has called to overridden primitives. * freeze.adb (Check_Inherited_Conditions): Build wrapper body for inherited primitive that requires it. * sem_disp.adb (Check_Dispatching_Operation): Such wrappers are legal primitive operations and belong to the list of bodies generated after the freeze point of a type. * sem_prag.adb (Build_Pragma_Check_Equivalent): Use new signature of Build_Class_Wide_Expression. * sem_util.adb, sem_util.ads (Build_Overriding_Spec): New procedure to construct the specification of the wrapper subprogram created for an inherited operation. From-SVN: r247140 --- gcc/ada/ChangeLog | 32 +++++++++++ gcc/ada/checks.adb | 9 +-- gcc/ada/exp_util.adb | 19 +++++-- gcc/ada/exp_util.ads | 14 +++-- gcc/ada/freeze.adb | 133 +++++++++++++++++++++++++++++++++++++------ gcc/ada/init.c | 2 +- gcc/ada/s-mmap.ads | 2 + gcc/ada/sem_disp.adb | 11 +++- gcc/ada/sem_prag.adb | 6 +- gcc/ada/sem_util.adb | 34 +++++++++++ gcc/ada/sem_util.ads | 8 +++ 11 files changed, 239 insertions(+), 31 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e06d7585e23..5b093d9aad7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2017-04-25 Tristan Gingold + + * s-mmap.ads (Data): Add pragma Inline. + +2017-04-25 Hristian Kirtchev + + * checks.adb (Insert_Valid_Check): Do not use + a renaming to alias a volatile name because this will lead to + multiple evaluations of the volatile name. Use a constant to + capture the value instead. + +2017-04-25 Doug Rupp + + * init.c [VxWorks Section]: Disable sigtramp for ppc64-vx7. + +2017-04-25 Ed Schonberg + + * exp_util.adb, exp_util.ads (Build_Class_Wide_Expression): + Add out parameter to indicate to caller that a wrapper must + be constructed for an inherited primitive whose inherited + pre/postcondition has called to overridden primitives. + * freeze.adb (Check_Inherited_Conditions): Build wrapper body + for inherited primitive that requires it. + * sem_disp.adb (Check_Dispatching_Operation): Such wrappers are + legal primitive operations and belong to the list of bodies + generated after the freeze point of a type. + * sem_prag.adb (Build_Pragma_Check_Equivalent): Use new signature + of Build_Class_Wide_Expression. + * sem_util.adb, sem_util.ads (Build_Overriding_Spec): New procedure + to construct the specification of the wrapper subprogram created + for an inherited operation. + 2017-04-25 Bob Duff * s-osinte-linux.ads (pthread_mutexattr_setprotocol, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index f0ba9a8ad9e..40d3f3cefd7 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7210,17 +7210,18 @@ package body Checks is end if; -- Build the prefix for the 'Valid call. If the expression denotes - -- a name, use a renaming to alias it, otherwise use a constant to - -- capture the value of the expression. + -- a non-volatile name, use a renaming to alias it, otherwise use a + -- constant to capture the value of the expression. - -- Temp : ... renames Expr; -- reference to a name + -- 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), + 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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 67a6c64a1d4..f9310bd4add 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1041,11 +1041,13 @@ package body Exp_Util is --------------------------------- procedure Build_Class_Wide_Expression - (Prag : Node_Id; - Subp : Entity_Id; - Par_Subp : Entity_Id; - Adjust_Sloc : Boolean) + (Prag : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Adjust_Sloc : Boolean; + Needs_Wrapper : out Boolean) is + function Replace_Entity (N : Node_Id) return Traverse_Result; -- Replace reference to formal of inherited operation or to primitive -- operation of root type, with corresponding entity for derived type, @@ -1089,6 +1091,13 @@ package body Exp_Util is if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + + -- If the entity is an overridden primitive, we must build + -- a wrapper for the current inherited operation. + + if Is_Subprogram (New_E) then + Needs_Wrapper := True; + end if; end if; -- Check that there are no calls left to abstract operations if @@ -1156,6 +1165,8 @@ package body Exp_Util is -- Start of processing for Build_Class_Wide_Expression begin + Needs_Wrapper := False; + -- Add mapping from old formals to new formals Par_Formal := First_Formal (Par_Subp); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 584c2df6ba6..a6b6b03521a 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -248,10 +248,11 @@ package Exp_Util is -- not install a call to Abort_Defer. procedure Build_Class_Wide_Expression - (Prag : Node_Id; - Subp : Entity_Id; - Par_Subp : Entity_Id; - Adjust_Sloc : Boolean); + (Prag : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Adjust_Sloc : Boolean; + Needs_Wrapper : out Boolean); -- Build the expression for an inherited class-wide condition. Prag is -- the pragma constructed from the corresponding aspect of the parent -- subprogram, and Subp is the overriding operation, and Par_Subp is @@ -264,6 +265,11 @@ package Exp_Util is -- is the expression of the original class-wide aspect. In SPARK_Mode, such -- operation which are just inherited but have modified pre/postconditions -- are illegal. + -- If there are calls to overridden operations in the condition, and the + -- pragma applies to an inherited operation, a wrapper must be built for + -- it to capture the new inherited condition. The flag Needs_Wrapper is + -- set in that case so that the wrapper can be built, when the controlling + -- type is frozen. function Build_DIC_Call (Loc : Source_Ptr; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 4d8e52cee74..645f0a750be 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -55,6 +55,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Prag; use Sem_Prag; @@ -1395,17 +1396,22 @@ package body Freeze is -------------------------------- procedure Check_Inherited_Conditions (R : Entity_Id) is - Prim_Ops : constant Elist_Id := Primitive_Operations (R); - A_Post : Node_Id; - A_Pre : Node_Id; - Op_Node : Elmt_Id; - Par_Prim : Entity_Id; - Prim : Entity_Id; + Prim_Ops : constant Elist_Id := Primitive_Operations (R); + A_Post : Node_Id; + A_Pre : Node_Id; + Decls : List_Id; + Op_Node : Elmt_Id; + Par_Prim : Entity_Id; + Par_Type : Entity_Id; + New_Prag : Node_Id; + Prim : Entity_Id; + Needs_Wrapper : Boolean; begin Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop - Prim := Node (Op_Node); + Prim := Node (Op_Node); + Needs_Wrapper := False; -- Map the overridden primitive to the overriding one. This takes -- care of all overridings and is done only once. @@ -1446,9 +1452,12 @@ package body Freeze is Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop - Prim := Node (Op_Node); + Decls := Empty_List; + Prim := Node (Op_Node); + if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); + Par_Type := Find_Dispatching_Type (Par_Prim); -- Analyze the contract items of the parent operation, before -- they are rewritten when inherited. @@ -1458,24 +1467,116 @@ package body Freeze is A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition); if Present (A_Pre) and then Class_Present (A_Pre) then + New_Prag := New_Copy_Tree (A_Pre); Build_Class_Wide_Expression - (Prag => New_Copy_Tree (A_Pre), - Subp => Prim, - Par_Subp => Par_Prim, - Adjust_Sloc => False); + (Prag => New_Prag, + Subp => Prim, + Par_Subp => Par_Prim, + Adjust_Sloc => False, + Needs_Wrapper => Needs_Wrapper); + + if Needs_Wrapper then + Append (New_Prag, Decls); + end if; end if; A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition); if Present (A_Post) and then Class_Present (A_Post) then + New_Prag := New_Copy_Tree (A_Pre); Build_Class_Wide_Expression - (Prag => New_Copy_Tree (A_Post), - Subp => Prim, - Par_Subp => Par_Prim, - Adjust_Sloc => False); + (Prag => New_Prag, + Subp => Prim, + Par_Subp => Par_Prim, + Adjust_Sloc => False, + Needs_Wrapper => Needs_Wrapper); + + if Needs_Wrapper then + Append (New_Prag, Decls); + end if; end if; end if; + if Needs_Wrapper and then not Is_Abstract_Subprogram (Par_Prim) then + + -- We need to build a new primitive that overrides the inherited + -- one, and whose inherited expression has been updated above. + -- These expressions are the arguments of pragmas that are part + -- of the declarations of the wrapper. The wrapper holds a single + -- statement that is a call to the parent primitive, where the + -- controlling actuals are conversions to the corresponding type + -- in the parent primitive: + + -- procedure New_Prim (F1 : T1.; ...) is + -- pragma Check (Precondition, Expr); + -- begin + -- Par_Prim (Par_Type (F1) ..); + -- end; + -- + -- If the primitive is a function the statement is a call. + + declare + Loc : constant Source_Ptr := Sloc (R); + Formal : Entity_Id; + Actuals : List_Id; + New_F_Spec : Node_Id; + New_Formal : Entity_Id; + New_Proc : Node_Id; + New_Spec : Node_Id; + Call : Node_Id; + + begin + Actuals := Empty_List; + New_Spec := Build_Overriding_Spec (Par_Prim, R); + Formal := First_Formal (Par_Prim); + New_F_Spec := First (Parameter_Specifications (New_Spec)); + + while Present (Formal) loop + New_Formal := Defining_Identifier (New_F_Spec); + + -- If controlling argument, add conversion. + + if Etype (Formal) = Par_Type then + Append_To (Actuals, + Make_Type_Conversion (Loc, + New_Occurrence_Of (Par_Type, Loc), + New_Occurrence_Of (New_Formal, Loc))); + + else + Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); + end if; + + Next_Formal (Formal); + Next (New_F_Spec); + end loop; + + if Ekind (Par_Prim) = E_Procedure then + Call := Make_Procedure_Call_Statement (Loc, + Parameter_Associations => Actuals, + Name => New_Occurrence_Of (Par_Prim, Loc)); + else + Call := Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Parameter_Associations => Actuals, + Name => New_Occurrence_Of (Par_Prim, Loc))); + end if; + + New_Proc := Make_Subprogram_Body (Loc, + Specification => New_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), + End_Label => Make_Identifier (Loc, Chars (Prim)))); + + Insert_After (Parent (R), New_Proc); + Analyze (New_Proc); + end; + + Needs_Wrapper := False; + end if; + Next_Elmt (Op_Node); end loop; end Check_Inherited_Conditions; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index e180f3cfb09..07155f02301 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2005,7 +2005,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); -#if defined (__ARMEL__) || defined (__PPC__) || defined (__i386__) || defined (__x86_64__) +#if defined (__ARMEL__) || (defined (__PPC__) && !defined (__PPC64__)) || defined (__i386__) || defined (__x86_64__) /* On certain targets, kernel mode, we process signals through a Call Frame Info trampoline, voiding the need for myriads of fallback_frame_state variants in the ZCX runtime. We have no simple way to distinguish ZCX diff --git a/gcc/ada/s-mmap.ads b/gcc/ada/s-mmap.ads index 00b080b02dd..7719367c805 100644 --- a/gcc/ada/s-mmap.ads +++ b/gcc/ada/s-mmap.ads @@ -223,11 +223,13 @@ package System.Mmap is -- (File); such accesses may cause Storage_Error to be raised. function Data (Region : Mapped_Region) return Str_Access; + pragma Inline (Data); -- The data mapped in Region as requested. The result is an unconstrained -- string, so you cannot use the usual 'First and 'Last attributes. -- Instead, these are respectively 1 and Size. function Data (File : Mapped_File) return Str_Access; + pragma Inline (Data); -- Likewise for the region contained in File function Is_Mutable (Region : Mapped_Region) return Boolean; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index ef1a20b151a..73bc8b6ceae 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1090,6 +1090,11 @@ package body Sem_Disp is -- 3. Subprograms associated with stream attributes (built by -- New_Stream_Subprogram) + -- 4. Wrapper built for inherited operations with inherited class- + -- wide conditions, where the conditions include calls to other + -- overridden primitives. The wrappers include checks on these + -- modified conditions. (AI12-113). + if Present (Old_Subp) and then Present (Overridden_Operation (Subp)) and then Is_Dispatching_Operation (Old_Subp) @@ -1098,14 +1103,18 @@ package body Sem_Disp is ((Ekind (Subp) = E_Function and then Is_Dispatching_Operation (Old_Subp) and then Is_Null_Extension (Base_Type (Etype (Subp)))) + or else (Ekind (Subp) = E_Procedure and then Is_Dispatching_Operation (Old_Subp) and then Present (Alias (Old_Subp)) and then Is_Null_Interface_Primitive (Ultimate_Alias (Old_Subp))) + or else Get_TSS_Name (Subp) = TSS_Stream_Read - or else Get_TSS_Name (Subp) = TSS_Stream_Write); + or else Get_TSS_Name (Subp) = TSS_Stream_Write + + or else Present (Contract (Overridden_Operation (Subp)))); Check_Controlling_Formals (Tagged_Type, Subp); Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index cae36e65caf..789aa31e654 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -27017,6 +27017,9 @@ package body Sem_Prag is Inher_Id : Entity_Id := Empty; Keep_Pragma_Id : Boolean := False) return Node_Id is + Needs_Wrapper : Boolean; + pragma Unreferenced (Needs_Wrapper); + function Suppress_Reference (N : Node_Id) return Traverse_Result; -- Detect whether node N references a formal parameter subject to -- pragma Unreferenced. If this is the case, set Comes_From_Source @@ -27085,7 +27088,8 @@ package body Sem_Prag is -- Build the inherited class-wide condition Build_Class_Wide_Expression - (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True); + (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True, + Needs_Wrapper => Needs_Wrapper); -- If not an inherited condition simply copy the original pragma diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f0690556bcf..53410cc7a7a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1581,6 +1581,40 @@ package body Sem_Util is Set_Etype (Expr, Designated_Type (Etype (Disc))); end Build_Explicit_Dereference; + --------------------------- + -- Build_Overriding_Spec -- + --------------------------- + + function Build_Overriding_Spec + (Op : Entity_Id; + Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Par_Typ : constant Entity_Id := Find_Dispatching_Type (Op); + Spec : constant Node_Id := Specification (Unit_Declaration_Node (Op)); + + Formal_Spec : Node_Id; + Formal_Type : Node_Id; + New_Spec : Node_Id; + begin + New_Spec := Copy_Subprogram_Spec (Spec); + Formal_Spec := First (Parameter_Specifications (New_Spec)); + while Present (Formal_Spec) loop + Formal_Type := Parameter_Type (Formal_Spec); + if Is_Entity_Name (Formal_Type) + and then Entity (Formal_Type) = Par_Typ + then + Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc)); + end if; + + -- Nothing needs to be done for access parameters. + + Next (Formal_Spec); + end loop; + + return New_Spec; + end Build_Overriding_Spec; + ----------------------------------- -- Cannot_Raise_Constraint_Error -- ----------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f9ab8135481..fb0bdf33a0c 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -227,6 +227,14 @@ package Sem_Util is -- the compilation unit, and install it in the Elaboration_Entity field -- of Spec_Id, the entity for the compilation unit. + function Build_Overriding_Spec + (Op : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Build a subprogram specification for the wrapper of an inherited + -- operation with a modified pre- or postcondition (See AI12-0113). + -- Op is the parent operation, and Typ is the descendant type that + -- inherits the operation. + procedure Build_Explicit_Dereference (Expr : Node_Id; Disc : Entity_Id); -- 2.30.2