From fe683ef6e1f215fa4836b0698c2b0265ff2da618 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 7 Sep 2017 11:53:18 +0200 Subject: [PATCH] [multiple changes] 2017-09-07 Nicolas Roche * s-traces-default.adb, s-trafor-default.adb, s-trafor-default.ads, s-traces.adb, s-traces.ads, s-tratas-default.adb, s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tratas.adb, s-tratas.ads, s-tasuti.adb, s-parame-hpux.ads, s-tassta.adb, s-taasde.adb, s-tasren.adb, s-taprob.adb, a-caldel.adb, s-parame.ads, Makefile.rtl, s-tpobop.adb, s-taenca.adb, s-parame-vxworks.ads: Remove support for System.Traces. 2017-09-07 Yannick Moy * a-ngelfu.ads Add preconditions to all functions listed in Ada RM A.5.1(19-33) as having constraints on inputs. 2017-09-07 Arnaud Charlet * lib-xref.adb (Generate_Reference): ignore references to entities which are Part_Of single concurrent objects. 2017-09-07 Eric Botcazou * sem_ch7.adb (Hide_Public_Entities): Add paragraph to main comment. 2017-09-07 Arnaud Charlet * a-taside.adb (Activation_Is_Complete): Raise Program_Error if Null_Task_Id is passed. 2017-09-07 Javier Miranda * einfo.ads, einfo.adb (Access_Disp_Table_Elab_Flag): New attribute. Defined for record types and subtypes. * exp_ch3.ads (Init_Secondary_Tags): Adding new formal (Init_Tags_List) to facilitate generating separate code in the IP routine to initialize the object components and for completing the elaboration of dispatch tables. * exp_ch3.adb (Build_Init_Procedure): Improve the code generated in the IP routines by means of keeping separate the initialization of the object components from the initialization of its dispatch tables. (Init_Secondary_Tags): Adding new formal (Init_Tags_List) and adjusting calls to Ada.Tags.Set_Dynamic_Offset_To_Top since it has a new formal; adjusting also calls to Ada.Tags.Register_Interface_Offset because the type of one of its formals has been changed. * a-tags.ads, a-tags.adb (Register_Interface_Offset): Profile modified. Instead of receiving a pointer to an object this routine receives now a primary tag. (Set_Dyanic_Offset_To_Top): Profile modified. This routine receives an additional formal: the tag of the primary dispatch table. * exp_disp.ads (Elab_Flag_Needed): New subprogram. * exp_disp.adb (Elab_Flag_Needed): New subprogram. (Make_Tags): Adding the declaration of the elaboration flag (if needed). * exp_aggr.adb (Build_Record_Aggr_Code): Adding actual of new formal in calls to Init_Secondary_Tags. 2017-09-07 Javier Miranda * ghost.adb (Mark_And_Set_Ghost_Instantiation.Check_Ghost_Actuals): New subprogram. * sem_prag.adb (Pragma_Ghost): Add missing support for ghost applied to generic subprograms. From-SVN: r251838 --- gcc/ada/ChangeLog | 64 +++++++++++++++++++++++++++++ gcc/ada/Makefile.rtl | 2 - gcc/ada/a-caldel.adb | 22 +--------- gcc/ada/a-ngelfu.ads | 41 +++++++++++++++++-- gcc/ada/a-tags.adb | 19 ++++----- gcc/ada/a-tags.ads | 40 ++++++++++-------- gcc/ada/a-taside.adb | 8 +++- gcc/ada/einfo.adb | 22 ++++++++++ gcc/ada/einfo.ads | 13 ++++++ gcc/ada/exp_aggr.adb | 6 ++- gcc/ada/exp_ch3.adb | 70 ++++++++++++++++++++++++-------- gcc/ada/exp_ch3.ads | 12 +++--- gcc/ada/exp_disp.adb | 29 +++++++++++++ gcc/ada/exp_disp.ads | 6 +++ gcc/ada/ghost.adb | 44 ++++++++++++++++++++ gcc/ada/lib-xref.adb | 13 ++++++ gcc/ada/s-parame-hpux.ads | 11 +---- gcc/ada/s-parame-vxworks.ads | 11 +---- gcc/ada/s-parame.ads | 11 +---- gcc/ada/s-taasde.adb | 8 ---- gcc/ada/s-taenca.adb | 28 ------------- gcc/ada/s-taprob.adb | 18 +------- gcc/ada/s-tasren.adb | 79 ------------------------------------ gcc/ada/s-tassta.adb | 17 +------- gcc/ada/s-tasuti.adb | 10 +---- gcc/ada/s-tpobop.adb | 25 +----------- gcc/ada/sem_ch7.adb | 6 +++ gcc/ada/sem_prag.adb | 5 +++ 28 files changed, 346 insertions(+), 294 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index dabb90f2982..a12767668ba 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,67 @@ +2017-09-07 Nicolas Roche + + * s-traces-default.adb, s-trafor-default.adb, s-trafor-default.ads, + s-traces.adb, s-traces.ads, s-tratas-default.adb, s-tfsetr-default.adb, + s-tfsetr-vxworks.adb, s-tratas.adb, s-tratas.ads, s-tasuti.adb, + s-parame-hpux.ads, s-tassta.adb, s-taasde.adb, s-tasren.adb, + s-taprob.adb, a-caldel.adb, s-parame.ads, Makefile.rtl, s-tpobop.adb, + s-taenca.adb, s-parame-vxworks.ads: Remove support for System.Traces. + +2017-09-07 Yannick Moy + + * a-ngelfu.ads Add preconditions to all functions + listed in Ada RM A.5.1(19-33) as having constraints on inputs. + +2017-09-07 Arnaud Charlet + + * lib-xref.adb (Generate_Reference): ignore + references to entities which are Part_Of single concurrent + objects. + +2017-09-07 Eric Botcazou + + * sem_ch7.adb (Hide_Public_Entities): Add paragraph to main + comment. + +2017-09-07 Arnaud Charlet + + * a-taside.adb (Activation_Is_Complete): Raise Program_Error if + Null_Task_Id is passed. + +2017-09-07 Javier Miranda + + * einfo.ads, einfo.adb (Access_Disp_Table_Elab_Flag): New + attribute. Defined for record types and subtypes. + * exp_ch3.ads (Init_Secondary_Tags): Adding new formal + (Init_Tags_List) to facilitate generating separate code in the + IP routine to initialize the object components and for completing + the elaboration of dispatch tables. + * exp_ch3.adb (Build_Init_Procedure): Improve the code + generated in the IP routines by means of keeping separate + the initialization of the object components from the + initialization of its dispatch tables. (Init_Secondary_Tags): + Adding new formal (Init_Tags_List) and adjusting calls to + Ada.Tags.Set_Dynamic_Offset_To_Top since it has a new formal; + adjusting also calls to Ada.Tags.Register_Interface_Offset + because the type of one of its formals has been changed. + * a-tags.ads, a-tags.adb (Register_Interface_Offset): Profile + modified. Instead of receiving a pointer to an object this + routine receives now a primary tag. + (Set_Dyanic_Offset_To_Top): Profile modified. This routine receives an + additional formal: the tag of the primary dispatch table. + * exp_disp.ads (Elab_Flag_Needed): New subprogram. + * exp_disp.adb (Elab_Flag_Needed): New subprogram. + (Make_Tags): Adding the declaration of the elaboration flag (if needed). + * exp_aggr.adb (Build_Record_Aggr_Code): Adding actual of new + formal in calls to Init_Secondary_Tags. + +2017-09-07 Javier Miranda + + * ghost.adb (Mark_And_Set_Ghost_Instantiation.Check_Ghost_Actuals): New + subprogram. + * sem_prag.adb (Pragma_Ghost): Add missing support for ghost + applied to generic subprograms. + 2017-09-07 Arnaud Charlet * sem_util.adb (Check_Part_Of_Reference): rename Conc_Typ to Conc_Obj diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4eb60b536dc..021da824c0d 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -73,7 +73,6 @@ GNATRTL_TASKING_OBJS= \ s-tpoben$(objext) \ s-tpobop$(objext) \ s-tposen$(objext) \ - s-tratas$(objext) \ thread$(objext) \ $(EXTRA_GNATRTL_TASKING_OBJS) @@ -673,7 +672,6 @@ GNATRTL_NONTASKING_OBJS= \ s-ststop$(objext) \ s-tasloc$(objext) \ s-traceb$(objext) \ - s-traces$(objext) \ s-traent$(objext) \ s-unstyp$(objext) \ s-utf_32$(objext) \ diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb index cb55324c0c5..efa4478dd59 100644 --- a/gcc/ada/a-caldel.adb +++ b/gcc/ada/a-caldel.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2017, 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- -- @@ -32,8 +32,6 @@ with System.OS_Primitives; with System.Soft_Links; -with System.Traces; -with System.Parameters; package body Ada.Calendar.Delays is @@ -42,8 +40,6 @@ package body Ada.Calendar.Delays is use type SSL.Timed_Delay_Call; - use System.Traces; - -- Earlier, System.Time_Operations was used to implement the following -- operations. The idea was to avoid sucking in the tasking packages. This -- did not work. Logically, we can't have it both ways. There is no way to @@ -64,16 +60,8 @@ package body Ada.Calendar.Delays is procedure Delay_For (D : Duration) is begin - if System.Parameters.Runtime_Traces then - Send_Trace_Info (W_Delay, D); - end if; - SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative); - - if System.Parameters.Runtime_Traces then - Send_Trace_Info (M_Delay, D); - end if; end Delay_For; ----------------- @@ -84,15 +72,7 @@ package body Ada.Calendar.Delays is D : constant Duration := To_Duration (T); begin - if System.Parameters.Runtime_Traces then - Send_Trace_Info (WU_Delay, D); - end if; - SSL.Timed_Delay.all (D, OSP.Absolute_Calendar); - - if System.Parameters.Runtime_Traces then - Send_Trace_Info (M_Delay, D); - end if; end Delay_Until; -------------------- diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads index 767708d5209..52a00d2771a 100644 --- a/gcc/ada/a-ngelfu.ads +++ b/gcc/ada/a-ngelfu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2012-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -41,7 +41,16 @@ package Ada.Numerics.Generic_Elementary_Functions with is pragma Pure; + -- Preconditions in this unit are meant for analysis only, not for run-time + -- checking, so that the expected exceptions are raised when calling + -- Assert. This is enforced by setting the corresponding assertion policy + -- to Ignore. This is done in the generic spec so that it applies to all + -- instances. + + pragma Assertion_Policy (Pre => Ignore); + function Sqrt (X : Float_Type'Base) return Float_Type'Base with + Pre => X >= 0.0, Post => Sqrt'Result >= 0.0 and then (if X = 0.0 then Sqrt'Result = 0.0) and then (if X = 1.0 then Sqrt'Result = 1.0) @@ -64,15 +73,18 @@ is and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0); function Log (X : Float_Type'Base) return Float_Type'Base with + Pre => X > 0.0, Post => (if X = 1.0 then Log'Result = 0.0); function Log (X, Base : Float_Type'Base) return Float_Type'Base with + Pre => X > 0.0 and Base > 0.0 and Base /= 1.0, Post => (if X = 1.0 then Log'Result = 0.0); function Exp (X : Float_Type'Base) return Float_Type'Base with Post => (if X = 0.0 then Exp'Result = 1.0); function "**" (Left, Right : Float_Type'Base) return Float_Type'Base with + Pre => (if Left = 0.0 then Right > 0.0) and Left >= 0.0, Post => "**"'Result >= 0.0 and then (if Right = 0.0 then "**"'Result = 1.0) and then (if Right = 1.0 then "**"'Result = Left) @@ -84,6 +96,7 @@ is and then (if X = 0.0 then Sin'Result = 0.0); function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0, Post => Sin'Result in -1.0 .. 1.0 and then (if X = 0.0 then Sin'Result = 0.0); @@ -92,6 +105,7 @@ is and then (if X = 0.0 then Cos'Result = 1.0); function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0, Post => Cos'Result in -1.0 .. 1.0 and then (if X = 0.0 then Cos'Result = 1.0); @@ -99,28 +113,40 @@ is Post => (if X = 0.0 then Tan'Result = 0.0); function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 + and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.25 * Cycle, Post => (if X = 0.0 then Tan'Result = 0.0); - function Cot (X : Float_Type'Base) return Float_Type'Base; + function Cot (X : Float_Type'Base) return Float_Type'Base with + Pre => X /= 0.0; - function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base; + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 + and then X /= 0.0 + and then Float_Type'Base'Remainder (X, Cycle) /= 0.0 + and then abs Float_Type'Base'Remainder (X, Cycle) = 0.5 * Cycle; function Arcsin (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X <= 1.0, Post => (if X = 0.0 then Arcsin'Result = 0.0); function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and abs X <= 1.0, Post => (if X = 0.0 then Arcsin'Result = 0.0); function Arccos (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X <= 1.0, Post => (if X = 1.0 then Arccos'Result = 0.0); function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and abs X <= 1.0, Post => (if X = 1.0 then Arccos'Result = 0.0); function Arctan (Y : Float_Type'Base; X : Float_Type'Base := 1.0) return Float_Type'Base with + Pre => X /= 0.0 or Y /= 0.0, Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); function Arctan @@ -128,12 +154,14 @@ is X : Float_Type'Base := 1.0; Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); function Arccot (X : Float_Type'Base; Y : Float_Type'Base := 1.0) return Float_Type'Base with + Pre => X /= 0.0 or Y /= 0.0, Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); function Arccot @@ -141,6 +169,7 @@ is Y : Float_Type'Base := 1.0; Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); function Sinh (X : Float_Type'Base) return Float_Type'Base with @@ -155,18 +184,22 @@ is and then (if X = 0.0 then Tanh'Result = 0.0); function Coth (X : Float_Type'Base) return Float_Type'Base with + Pre => X /= 0.0, Post => abs Coth'Result >= 1.0; function Arcsinh (X : Float_Type'Base) return Float_Type'Base with Post => (if X = 0.0 then Arcsinh'Result = 0.0); function Arccosh (X : Float_Type'Base) return Float_Type'Base with + Pre => X >= 1.0, Post => Arccosh'Result >= 0.0 and then (if X = 1.0 then Arccosh'Result = 0.0); function Arctanh (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X /= 1.0, Post => (if X = 0.0 then Arctanh'Result = 0.0); - function Arccoth (X : Float_Type'Base) return Float_Type'Base; + function Arccoth (X : Float_Type'Base) return Float_Type'Base with + Pre => X <= 1.0 and abs X /= 1.0; end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 95bc2087df3..fd997829203 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -906,22 +906,16 @@ package body Ada.Tags is ------------------------------- procedure Register_Interface_Offset - (This : System.Address; + (Prim_T : Tag; Interface_T : Tag; Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr) is - Prim_DT : Dispatch_Table_Ptr; - Iface_Table : Interface_Data_Ptr; - + Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T); + Iface_Table : constant Interface_Data_Ptr := + To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; begin - -- "This" points to the primary DT and we must save Offset_Value in - -- the Offset_To_Top field of the corresponding dispatch table. - - Prim_DT := DT (To_Tag_Ptr (This).all); - Iface_Table := To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; - -- Save Offset_Value in the table of interfaces of the primary DT. -- This data will be used by the subprogram "Displace" to give support -- to backward abstract interface type conversions. @@ -1008,6 +1002,7 @@ package body Ada.Tags is procedure Set_Dynamic_Offset_To_Top (This : System.Address; + Prim_T : Tag; Interface_T : Tag; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr) @@ -1025,7 +1020,7 @@ package body Ada.Tags is end if; Register_Interface_Offset - (This, Interface_T, False, Offset_Value, Offset_Func); + (Prim_T, Interface_T, False, Offset_Value, Offset_Func); end Set_Dynamic_Offset_To_Top; ---------------------- diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 7397de57324..df578eb1839 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -527,18 +527,18 @@ private -- assumes that _size is always in slot one of the dispatch table. procedure Register_Interface_Offset - (This : System.Address; + (Prim_T : Tag; Interface_T : Tag; Is_Static : Boolean; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr); -- Register in the table of interfaces of the tagged type associated with - -- "This" object the offset of the record component associated with the - -- progenitor Interface_T (that is, the distance from "This" to the object - -- component containing the tag of the secondary dispatch table). In case - -- of constant offset, Is_Static is true and Offset_Value has such value. - -- In case of variable offset, Is_Static is false and Offset_Func is an - -- access to function that must be called to evaluate the offset. + -- Prim_T the offset of the record component associated with the progenitor + -- Interface_T (that is, the distance from "This" to the object component + -- containing the tag of the secondary dispatch table). In case of constant + -- offset, Is_Static is true and Offset_Value has such value. In case of + -- variable offset, Is_Static is false and Offset_Func is an access to + -- function that must be called to evaluate the offset. procedure Register_Tag (T : Tag); -- Insert the Tag and its associated external_tag in a table for the sake @@ -546,20 +546,24 @@ private procedure Set_Dynamic_Offset_To_Top (This : System.Address; + Prim_T : Tag; Interface_T : Tag; Offset_Value : SSE.Storage_Offset; Offset_Func : Offset_To_Top_Function_Ptr); -- Ada 2005 (AI-251): The compiler generates calls to this routine only - -- when initializing the Offset_To_Top field of dispatch tables associated - -- with tagged type whose parent has variable size components. "This" is - -- the object whose dispatch table is being initialized. Interface_T is the - -- interface for which the secondary dispatch table is being initialized, - -- and Offset_Value is the distance from "This" to the object component - -- containing the tag of the secondary dispatch table (a zero value means - -- that this interface shares the primary dispatch table). Offset_Func - -- references a function that must be called to evaluate the offset at - -- runtime. This routine also takes care of registering these values in - -- the table of interfaces of the type. + -- when initializing the Offset_To_Top field of dispatch tables of tagged + -- types that cover interface types whose parent type has variable size + -- components. + -- + -- "This" is the object whose dispatch table is being initialized. Prim_T + -- is the primary tag of such object. Interface_T is the interface tag for + -- which the secondary dispatch table is being initialized, Offset_Value + -- is the distance from "This" to the object component containing the tag + -- of the secondary dispatch table (a zero value means that this interface + -- shares the primary dispatch table). Offset_Func references a function + -- that must be called to evaluate the offset at runtime. This routine also + -- takes care of registering these values in the table of interfaces of the + -- type. procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb index b916c7609a1..9433669a6eb 100644 --- a/gcc/ada/a-taside.adb +++ b/gcc/ada/a-taside.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -92,7 +92,11 @@ is function Activation_Is_Complete (T : Task_Id) return Boolean is use type System.Tasking.Task_Id; begin - return Convert_Ids (T).Common.Activator = null; + if T = Null_Task_Id then + raise Program_Error; + else + return Convert_Ids (T).Common.Activator = null; + end if; end Activation_Is_Complete; ----------------- diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 4ad9466404f..3ecf3229b8a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -249,6 +249,7 @@ package body Einfo is -- BIP_Initialization_Call Node29 -- Subprograms_For_Type Elist29 + -- Access_Disp_Table_Elab_Flag Node30 -- Anonymous_Object Node30 -- Corresponding_Equality Node30 -- Last_Aggregate_Assignment Node30 @@ -724,6 +725,14 @@ package body Einfo is return Elist16 (Implementation_Base_Type (Id)); end Access_Disp_Table; + function Access_Disp_Table_Elab_Flag (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Record_Type, + E_Record_Type_With_Private, + E_Record_Subtype)); + return Node30 (Implementation_Base_Type (Id)); + end Access_Disp_Table_Elab_Flag; + function Activation_Record_Component (Id : E) return E is begin pragma Assert (Ekind_In (Id, E_Constant, @@ -3817,6 +3826,14 @@ package body Einfo is Set_Elist16 (Id, V); end Set_Access_Disp_Table; + procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E) is + begin + pragma Assert (Ekind (Id) = E_Record_Type + and then Id = Implementation_Base_Type (Id)); + pragma Assert (Is_Tagged_Type (Id)); + Set_Node30 (Id, V); + end Set_Access_Disp_Table_Elab_Flag; + procedure Set_Anonymous_Designated_Type (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Variable); @@ -10855,6 +10872,11 @@ package body Einfo is procedure Write_Field30_Name (Id : Entity_Id) is begin case Ekind (Id) is + when E_Record_Type + | E_Record_Type_With_Private + => + Write_Str ("Access_Disp_Table_Elab_Flag"); + when E_Protected_Type | E_Task_Type => diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2fcdac70e30..928ea3c475c 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -355,6 +355,14 @@ package Einfo is -- used to expand dispatching calls through the primary dispatch table. -- For an untagged record, contains No_Elist. +-- Access_Disp_Table_Elab_Flag (Node30) [implementation base type only] +-- Defined in E_Record_Type and E_Record_Subtype entities. Set in tagged +-- types whose dispatch table elaboration must be completed at runtime by +-- the IP routine to point to its pending elaboration flag entity. This +-- flag is needed when the elaboration of the dispatch table relies on +-- attribute 'Position applied to an object of the type; it is used by +-- the IP routine to avoid performing this elaboration twice. + -- Activation_Record_Component (Node31) -- Defined in E_Variable, E_Constant, E_Loop_Parameter, E_In_Parameter, -- E_Out_Parameter, E_In_Out_Parameter nodes. Used only if we are in @@ -6466,6 +6474,7 @@ package Einfo is -- E_Record_Subtype -- Direct_Primitive_Operations (Elist10) -- Access_Disp_Table (Elist16) (base type only) + -- Access_Disp_Table_Elab_Flag (Node30) (base type only) -- Cloned_Subtype (Node16) (subtype case only) -- First_Entity (Node17) -- Corresponding_Concurrent_Type (Node18) @@ -6911,6 +6920,7 @@ package Einfo is function Abstract_States (Id : E) return L; function Accept_Address (Id : E) return L; function Access_Disp_Table (Id : E) return L; + function Access_Disp_Table_Elab_Flag (Id : E) return E; function Activation_Record_Component (Id : E) return E; function Actual_Subtype (Id : E) return E; function Address_Taken (Id : E) return B; @@ -7602,6 +7612,7 @@ package Einfo is procedure Set_Abstract_States (Id : E; V : L); procedure Set_Accept_Address (Id : E; V : L); procedure Set_Access_Disp_Table (Id : E; V : L); + procedure Set_Access_Disp_Table_Elab_Flag (Id : E; V : E); procedure Set_Activation_Record_Component (Id : E; V : E); procedure Set_Actual_Subtype (Id : E; V : E); procedure Set_Address_Taken (Id : E; V : B := True); @@ -8415,6 +8426,7 @@ package Einfo is pragma Inline (Abstract_States); pragma Inline (Accept_Address); pragma Inline (Access_Disp_Table); + pragma Inline (Access_Disp_Table_Elab_Flag); pragma Inline (Activation_Record_Component); pragma Inline (Actual_Subtype); pragma Inline (Address_Taken); @@ -8941,6 +8953,7 @@ package Einfo is pragma Inline (Set_Abstract_States); pragma Inline (Set_Accept_Address); pragma Inline (Set_Access_Disp_Table); + pragma Inline (Set_Access_Disp_Table_Elab_Flag); pragma Inline (Set_Activation_Record_Component); pragma Inline (Set_Actual_Subtype); pragma Inline (Set_Address_Taken); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9ab9573edd1..71f2840b63b 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3324,7 +3324,8 @@ package body Exp_Aggr is Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, - Stmts_List => Assign); + Stmts_List => Assign, + Init_Tags_List => Assign); end if; end if; @@ -3859,7 +3860,8 @@ package body Exp_Aggr is Init_Secondary_Tags (Typ => Base_Type (Typ), Target => Target, - Stmts_List => L); + Stmts_List => L, + Init_Tags_List => L); end if; end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index d76aa71184a..69db5dd6a44 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2475,18 +2475,44 @@ package body Exp_Ch3 is and then not Is_Interface (Rec_Type) and then Has_Interfaces (Rec_Type) then - Init_Secondary_Tags - (Typ => Rec_Type, - Target => Make_Identifier (Loc, Name_uInit), - Stmts_List => Init_Tags_List, - Fixed_Comps => True, - Variable_Comps => False); - end if; + declare + Elab_Sec_DT_Stmts_List : constant List_Id := New_List; - Prepend_To (Body_Stmts, - Make_If_Statement (Loc, - Condition => New_Occurrence_Of (Set_Tag, Loc), - Then_Statements => Init_Tags_List)); + begin + Init_Secondary_Tags + (Typ => Rec_Type, + Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, + Stmts_List => Elab_Sec_DT_Stmts_List, + Fixed_Comps => True, + Variable_Comps => False); + + Append_To (Elab_Sec_DT_Stmts_List, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of + (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), + Expression => + New_Occurrence_Of (Standard_False, Loc))); + + Prepend_List_To (Body_Stmts, + New_List ( + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List), + + Make_If_Statement (Loc, + Condition => + New_Occurrence_Of + (Access_Disp_Table_Elab_Flag (Rec_Type), Loc), + Then_Statements => Elab_Sec_DT_Stmts_List))); + end; + else + Prepend_To (Body_Stmts, + Make_If_Statement (Loc, + Condition => New_Occurrence_Of (Set_Tag, Loc), + Then_Statements => Init_Tags_List)); + end if; -- Case 2: CPP type. The imported C++ constructor takes care of -- tags initialization. No action needed here because the IP @@ -2533,6 +2559,7 @@ package body Exp_Ch3 is Init_Secondary_Tags (Typ => Rec_Type, Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, Stmts_List => Init_Tags_List, Fixed_Comps => True, Variable_Comps => False); @@ -2606,6 +2633,7 @@ package body Exp_Ch3 is Init_Secondary_Tags (Typ => Rec_Type, Target => Make_Identifier (Loc, Name_uInit), + Init_Tags_List => Init_Tags_List, Stmts_List => Init_Tags_List, Fixed_Comps => False, Variable_Comps => True); @@ -8119,6 +8147,7 @@ package body Exp_Ch3 is procedure Init_Secondary_Tags (Typ : Entity_Id; Target : Node_Id; + Init_Tags_List : List_Id; Stmts_List : List_Id; Fixed_Comps : Boolean := True; Variable_Comps : Boolean := True) @@ -8156,7 +8185,7 @@ package body Exp_Ch3 is -- Initialize pointer to secondary DT associated with the interface if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then - Append_To (Stmts_List, + Append_To (Init_Tags_List, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -8190,6 +8219,7 @@ package body Exp_Ch3 is -- Generate: -- Set_Dynamic_Offset_To_Top -- (This => Init, + -- Prim_T => Typ'Tag, -- Interface_T => Iface'Tag, -- Offset_Value => n, -- Offset_Func => Fn'Address) @@ -8203,6 +8233,10 @@ package body Exp_Ch3 is Prefix => New_Copy_Tree (Target), Attribute_Name => Name_Address), + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), + Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Iface))), @@ -8230,7 +8264,7 @@ package body Exp_Ch3 is Offset_To_Top_Comp := Next_Entity (Tag_Comp); pragma Assert (Present (Offset_To_Top_Comp)); - Append_To (Stmts_List, + Append_To (Init_Tags_List, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, @@ -8269,7 +8303,7 @@ package body Exp_Ch3 is -- Generate: -- Register_Interface_Offset - -- (This => Init, + -- (Prim_T => Typ'Tag, -- Interface_T => Iface'Tag, -- Is_Constant => True, -- Offset_Value => n, @@ -8282,9 +8316,9 @@ package body Exp_Ch3 is New_Occurrence_Of (RTE (RE_Register_Interface_Offset), Loc), Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Copy_Tree (Target), - Attribute_Name => Name_Address), + Unchecked_Convert_To (RTE (RE_Tag), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)), Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of @@ -8403,7 +8437,7 @@ package body Exp_Ch3 is -- Initialize secondary tags else - Append_To (Stmts_List, + Append_To (Init_Tags_List, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index e42fc821f39..c1e6798a1da 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -94,15 +94,17 @@ package Exp_Ch3 is procedure Init_Secondary_Tags (Typ : Entity_Id; Target : Node_Id; + Init_Tags_List : List_Id; Stmts_List : List_Id; Fixed_Comps : Boolean := True; Variable_Comps : Boolean := True); -- Ada 2005 (AI-251): Initialize the tags of the secondary dispatch tables -- of Typ. The generated code referencing tag fields of Target is appended - -- to Stmts_List. If Fixed_Comps is True then the tag components located at - -- fixed positions of Target are initialized; if Variable_Comps is True - -- then tags components located at variable positions of Target are - -- initialized. + -- to Init_Tags_List and the code required to complete the elaboration of + -- the dispatch tables of Typ is appended to Stmts_List. If Fixed_Comps is + -- True then the tag components located at fixed positions of Target are + -- initialized; if Variable_Comps is True then tags components located at + -- variable positions of Target are initialized. function Make_Tag_Assignment (N : Node_Id) return Node_Id; -- An object declaration that has an initialization for a tagged object diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2b633778835..77833548cd2 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -625,6 +625,17 @@ package body Exp_Disp is raise Program_Error; end Default_Prim_Op_Position; + ---------------------- + -- Elab_Flag_Needed -- + ---------------------- + + function Elab_Flag_Needed (Typ : Entity_Id) return Boolean is + begin + return Ada_Version >= Ada_2005 + and then not Is_Interface (Typ) + and then Has_Interfaces (Typ); + end Elab_Flag_Needed; + ----------------------------- -- Expand_Dispatching_Call -- ----------------------------- @@ -6670,6 +6681,24 @@ package body Exp_Disp is pragma Assert (No (Access_Disp_Table (Typ))); Set_Access_Disp_Table (Typ, New_Elmt_List); + -- If the elaboration of this tagged type needs a boolean flag then + -- define now its entity. It is initialized to True to indicate that + -- elaboration is still pending; set to False by the IP routine. + + -- TypFxx : boolean := True; + + if Elab_Flag_Needed (Typ) then + Set_Access_Disp_Table_Elab_Flag (Typ, + Make_Defining_Identifier (Loc, + New_External_Name (Tname, 'F', Suffix_Index => -1))); + + Append_To (Result, + Make_Object_Declaration (Loc, + Defining_Identifier => Access_Disp_Table_Elab_Flag (Typ), + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + -- 1) Generate the primary tag entities -- Primary dispatch table containing user-defined primitives diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 61f13e839c4..7cb56d8829e 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -214,6 +214,12 @@ package Exp_Disp is -- Return the number of primitives of the C++ part of the dispatch table. -- For types that are not derivations of CPP types return 0. + function Elab_Flag_Needed (Typ : Entity_Id) return Boolean; + -- Return True if the elaboration of the tagged type Typ is completed at + -- runtime by the execution of code located in the IP routine and the + -- expander must generate an extra elaboration flag to avoid performing + -- such elaboration twice. + procedure Expand_Dispatching_Call (Call_Node : Node_Id); -- Expand the call to the operation through the dispatch table and perform -- the required tag checks when appropriate. For CPP types tag checks are diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 78ba5f3e133..6640d6a0f8e 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -1303,6 +1303,43 @@ package body Ghost is (N : Node_Id; Gen_Id : Entity_Id) is + procedure Check_Ghost_Actuals; + -- Check the context of ghost actuals + + ------------------------- + -- Check_Ghost_Actuals -- + ------------------------- + + procedure Check_Ghost_Actuals is + Assoc : Node_Id := First (Generic_Associations (N)); + Act : Node_Id; + + begin + while Present (Assoc) loop + if Nkind (Assoc) /= N_Others_Choice then + Act := Explicit_Generic_Actual_Parameter (Assoc); + + -- Within a nested instantiation, a defaulted actual is an + -- empty association, so nothing to check. + + if No (Act) then + null; + + elsif Comes_From_Source (Act) + and then Nkind (Act) in N_Has_Etype + and then Present (Etype (Act)) + and then Is_Ghost_Entity (Etype (Act)) + then + Check_Ghost_Context (Etype (Act), Act); + end if; + end if; + + Next (Assoc); + end loop; + end Check_Ghost_Actuals; + + -- Local variables + Policy : Name_Id := No_Name; begin @@ -1336,6 +1373,13 @@ package body Ghost is -- Install the appropriate Ghost mode Install_Ghost_Mode (Policy); + + -- Check ghost actuals. Given that this routine is unconditionally + -- invoked with subprogram and package instantiations, this check + -- verifies the context of all the ghost entities passed in generic + -- instantiations. + + Check_Ghost_Actuals; end Mark_And_Set_Ghost_Instantiation; --------------------------------------- diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index edc955b15b4..9cc54ebb958 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1126,6 +1126,19 @@ package body Lib.Xref is -- Comment needed here for special SPARK code ??? if GNATprove_Mode then + -- Ignore reference to an entity that is a Part_Of single + -- concurrent object. Ideally we would prefer to add it as a + -- reference to the corresponding concurrent type, but it is quite + -- difficult (as such references are not currently added even for) + -- reads/writes of private protected components) and not worth the + -- effort. + if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable) + and then Present (Encapsulating_State (Ent)) + and then Is_Single_Concurrent_Object (Encapsulating_State (Ent)) + then + return; + end if; + Ref := Sloc (Nod); Def := Sloc (Ent); diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index 319195644e5..f20cfbebe7e 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -181,15 +181,6 @@ package System.Parameters is Max_Attribute_Count : constant := 32; -- Number of task attributes stored in the task control block - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - ----------------------- -- Task Image Length -- ----------------------- diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index 10769cd696c..919361ad10d 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -183,15 +183,6 @@ package System.Parameters is Max_Attribute_Count : constant := 16; -- Number of task attributes stored in the task control block - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - ----------------------- -- Task Image Length -- ----------------------- diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index 2c2a2fadac9..f48c7e0973f 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -183,15 +183,6 @@ package System.Parameters is Max_Attribute_Count : constant := 32; -- Number of task attributes stored in the task control block - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - ----------------------- -- Task Image Length -- ----------------------- diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb index d7be38473ea..cab0be7b13e 100644 --- a/gcc/ada/s-taasde.adb +++ b/gcc/ada/s-taasde.adb @@ -42,8 +42,6 @@ with System.Tasking.Initialization; with System.Tasking.Debug; with System.OS_Primitives; with System.Interrupt_Management.Operations; -with System.Parameters; -with System.Traces.Tasking; package body System.Tasking.Async_Delays is @@ -54,8 +52,6 @@ package body System.Tasking.Async_Delays is package OSP renames System.OS_Primitives; use Parameters; - use System.Traces; - use System.Traces.Tasking; function To_System is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, Task_Id); @@ -369,10 +365,6 @@ package body System.Tasking.Async_Delays is -- the timer queue, but that is OK because we always restart the -- next iteration at the head of the queue. - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Kill, Dequeued.Self_Id); - end if; - STPO.Unlock (Timer_Server_ID); STPO.Write_Lock (Dequeued.Self_Id); Dequeued_Task := Dequeued.Self_Id; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index 9fa1384a14a..1236194441c 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -36,7 +36,6 @@ with System.Tasking.Protected_Objects.Operations; with System.Tasking.Queuing; with System.Tasking.Utilities; with System.Parameters; -with System.Traces; package body System.Tasking.Entry_Calls is @@ -46,7 +45,6 @@ package body System.Tasking.Entry_Calls is use Task_Primitives; use Protected_Objects.Entries; use Protected_Objects.Operations; - use System.Traces; -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock -- internally. Those operations will raise Program_Error, which @@ -478,10 +476,6 @@ package body System.Tasking.Entry_Calls is -- If this is a conditional call, it should be cancelled when it -- becomes abortable. This is checked in the loop below. - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Completion); - end if; - Self_Id.Common.State := Entry_Caller_Sleep; -- Try to remove calls to Sleep in the loop below by letting the caller @@ -515,9 +509,6 @@ package body System.Tasking.Entry_Calls is Self_Id.Common.State := Runnable; Utilities.Exit_One_ATC_Level (Self_Id); - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Call_Complete); - end if; end Wait_For_Completion; -------------------------------------- @@ -567,10 +558,6 @@ package body System.Tasking.Entry_Calls is -- is allowed to wake up at any time, not just when the condition is -- signaled. See same loop in the ordinary Wait_For_Completion, above. - if Parameters.Runtime_Traces then - Send_Trace_Info (WT_Completion, Wakeup_Time); - end if; - loop Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); exit when Entry_Call.State >= Done; @@ -579,10 +566,6 @@ package body System.Tasking.Entry_Calls is Entry_Caller_Sleep, Timedout, Yielded); if Timedout then - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Timeout); - end if; - -- Try to cancel the call (see Try_To_Cancel_Entry_Call for -- corresponding code in the ATC case). @@ -620,10 +603,6 @@ package body System.Tasking.Entry_Calls is -- This last part is the same as ordinary Wait_For_Completion, -- and is only executed if the call completed without timing out. - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Call_Complete); - end if; - Self_Id.Common.State := Runnable; Utilities.Exit_One_ATC_Level (Self_Id); end Wait_For_Completion_With_Timeout; @@ -640,10 +619,6 @@ package body System.Tasking.Entry_Calls is pragma Assert (Self_ID.ATC_Nesting_Level > 0); pragma Assert (Call.Mode = Asynchronous_Call); - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Completion); - end if; - STPO.Write_Lock (Self_ID); Self_ID.Common.State := Entry_Caller_Sleep; @@ -656,9 +631,6 @@ package body System.Tasking.Entry_Calls is Self_ID.Common.State := Runnable; STPO.Unlock (Self_ID); - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Call_Complete); - end if; end Wait_Until_Abortable; end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 755b772260a..8ba5198cce7 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -6,8 +6,8 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, AdaCore -- +-- Copyright (C) 1991-1997, Florida State University -- +-- Copyright (C) 1995-2017, 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- -- @@ -35,8 +35,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with System.Task_Primitives.Operations; -with System.Parameters; -with System.Traces; with System.Soft_Links.Tasking; with System.Secondary_Stack; @@ -48,7 +46,6 @@ pragma Unreferenced (System.Secondary_Stack); package body System.Tasking.Protected_Objects is use System.Task_Primitives.Operations; - use System.Traces; ---------------- -- Local Data -- @@ -128,10 +125,6 @@ package body System.Tasking.Protected_Objects is Write_Lock (Object.L'Access, Ceiling_Violation); - if Parameters.Runtime_Traces then - Send_Trace_Info (PO_Lock); - end if; - if Ceiling_Violation then raise Program_Error; end if; @@ -185,10 +178,6 @@ package body System.Tasking.Protected_Objects is Read_Lock (Object.L'Access, Ceiling_Violation); - if Parameters.Runtime_Traces then - Send_Trace_Info (PO_Lock); - end if; - if Ceiling_Violation then raise Program_Error; end if; @@ -271,9 +260,6 @@ package body System.Tasking.Protected_Objects is Unlock (Object.L'Access); - if Parameters.Runtime_Traces then - Send_Trace_Info (PO_Unlock); - end if; end Unlock; begin diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index b5e85e15087..c1b35482c41 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -38,7 +38,6 @@ with System.Tasking.Protected_Objects.Operations; with System.Tasking.Debug; with System.Restrictions; with System.Parameters; -with System.Traces.Tasking; package body System.Tasking.Rendezvous is @@ -48,8 +47,6 @@ package body System.Tasking.Rendezvous is use Parameters; use Task_Primitives.Operations; - use System.Traces; - use System.Traces.Tasking; type Select_Treatment is ( Accept_Alternative_Selected, -- alternative with non-null body @@ -200,10 +197,6 @@ package body System.Tasking.Rendezvous is -- Wait for normal call - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); - end if; - pragma Debug (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); Wait_For_Call (Self_Id); @@ -232,9 +225,6 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort (Self_Id); - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E)); - end if; end Accept_Call; -------------------- @@ -285,10 +275,6 @@ package body System.Tasking.Rendezvous is Open_Accepts (1).S := E; Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length)); - end if; - pragma Debug (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); @@ -314,15 +300,6 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Caller); end if; - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Accept_Complete); - - -- Fake one, since there is (???) no way to know that the rendezvous - -- is over. - - Send_Trace_Info (M_RDV_Complete); - end if; - if Single_Lock then Unlock_RTS; end if; @@ -404,10 +381,6 @@ package body System.Tasking.Rendezvous is Entry_Call.Mode := Mode; Entry_Call.Cancellation_Attempted := False; - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); - end if; - -- If this is a call made inside of an abort deferred region, -- the call should be never abortable. @@ -438,10 +411,6 @@ package body System.Tasking.Rendezvous is Unlock_RTS; end if; - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Missed, Acceptor); - end if; - Local_Undefer_Abort (Self_Id); raise Tasking_Error; end if; @@ -560,10 +529,6 @@ package body System.Tasking.Rendezvous is -- The call came from normal end-of-rendezvous, so abort is not yet -- deferred. - if Parameters.Runtime_Traces then - Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); - end if; - Initialization.Defer_Abort (Self_Id); elsif ZCX_By_Default then @@ -848,10 +813,6 @@ package body System.Tasking.Rendezvous is -- Accept body is null, so rendezvous is over immediately - if Parameters.Runtime_Traces then - Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); - end if; - STPO.Unlock (Self_Id); Caller := Entry_Call.Self; @@ -867,11 +828,6 @@ package body System.Tasking.Rendezvous is pragma Debug (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Select, Self_Id, - Integer (Open_Accepts'Length)); - end if; - Wait_For_Call (Self_Id); pragma Assert (Self_Id.Open_Accepts = null); @@ -908,10 +864,6 @@ package body System.Tasking.Rendezvous is when Else_Selected => pragma Assert (Self_Id.Open_Accepts = null); - if Parameters.Runtime_Traces then - Send_Trace_Info (M_Select_Else); - end if; - STPO.Unlock (Self_Id); when Terminate_Selected => @@ -1320,10 +1272,6 @@ package body System.Tasking.Rendezvous is "potentially blocking operation"; end if; - if Parameters.Runtime_Traces then - Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); - end if; - if Mode = Simple_Call or else Mode = Conditional_Call then Call_Synchronous (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); @@ -1369,10 +1317,6 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort (Self_Id); - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Missed, Acceptor); - end if; - raise Tasking_Error; end if; @@ -1514,10 +1458,6 @@ package body System.Tasking.Rendezvous is -- Rendezvous is over - if Parameters.Runtime_Traces then - Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); - end if; - STPO.Unlock (Self_Id); Caller := Entry_Call.Self; @@ -1568,23 +1508,12 @@ package body System.Tasking.Rendezvous is if Timedout then Sleep (Self_Id, Acceptor_Delay_Sleep); else - if Parameters.Runtime_Traces then - Send_Trace_Info (WT_Select, - Self_Id, - Integer (Open_Accepts'Length), - Timeout); - end if; - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, Timedout, Yielded); end if; if Timedout then Self_Id.Open_Accepts := null; - - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Timeout); - end if; end if; end loop; @@ -1700,11 +1629,6 @@ package body System.Tasking.Rendezvous is (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); - if Parameters.Runtime_Traces then - Send_Trace_Info (WT_Call, Acceptor, - Entry_Index (E), Timeout); - end if; - Level := Self_Id.ATC_Nesting_Level; Entry_Call := Self_Id.Entry_Calls (Level)'Access; Entry_Call.Next := null; @@ -1744,9 +1668,6 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort (Self_Id); - if Parameters.Runtime_Traces then - Send_Trace_Info (E_Missed, Acceptor); - end if; raise Tasking_Error; end if; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 7e0bdcb9e30..346e5bfe142 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -52,7 +52,6 @@ with System.OS_Primitives; with System.Secondary_Stack; with System.Restrictions; with System.Standard_Library; -with System.Traces.Tasking; with System.Stack_Usage; with System.Storage_Elements; @@ -81,9 +80,6 @@ package body System.Tasking.Stages is use Task_Primitives.Operations; use Task_Info; - use System.Traces; - use System.Traces.Tasking; - ----------------------- -- Local Subprograms -- ----------------------- @@ -426,9 +422,6 @@ package body System.Tasking.Stages is -- ??? Why do we need to allow for nested deferral here? - if Runtime_Traces then - Send_Trace_Info (T_Activate); - end if; end Complete_Activation; --------------------- @@ -709,10 +702,6 @@ package body System.Tasking.Stages is Created_Task := T; Initialization.Undefer_Abort_Nestable (Self_ID); - if Runtime_Traces then - Send_Trace_Info (T_Create, T); - end if; - pragma Debug (Debug.Trace (Self_ID, "Created task in " & T.Master_of_Task'Img, 'C', T)); @@ -1453,10 +1442,6 @@ package body System.Tasking.Stages is begin Debug.Task_Termination_Hook; - if Runtime_Traces then - Send_Trace_Info (T_Terminate); - end if; - -- Since GCC cannot allocate stack chunks efficiently without reordering -- some of the allocations, we have to handle this unexpected situation -- here. Normally we never have to call Vulnerable_Complete_Task here. diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb index 1a6444838a7..1a7e8cf9f10 100644 --- a/gcc/ada/s-tasuti.adb +++ b/gcc/ada/s-tasuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -42,7 +42,6 @@ with System.Task_Primitives.Operations; with System.Tasking.Initialization; with System.Tasking.Queuing; with System.Parameters; -with System.Traces.Tasking; package body System.Tasking.Utilities is @@ -53,9 +52,6 @@ package body System.Tasking.Utilities is use Task_Primitives; use Task_Primitives.Operations; - use System.Traces; - use System.Traces.Tasking; - -------------------- -- Abort_One_Task -- -------------------- @@ -67,10 +63,6 @@ package body System.Tasking.Utilities is procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is begin - if Parameters.Runtime_Traces then - Send_Trace_Info (T_Abort, Self_ID, T); - end if; - Write_Lock (T); if T.Common.State = Unactivated then diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 379ec41dfec..242fe45f97e 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -49,7 +49,6 @@ with System.Tasking.Rendezvous; with System.Tasking.Utilities; with System.Tasking.Debug; with System.Parameters; -with System.Traces.Tasking; with System.Restrictions; with System.Tasking.Initialization; @@ -67,8 +66,6 @@ package body System.Tasking.Protected_Objects.Operations is use System.Restrictions; use System.Restrictions.Rident; - use System.Traces; - use System.Traces.Tasking; ----------------------- -- Local Subprograms -- @@ -272,13 +269,6 @@ package body System.Tasking.Protected_Objects.Operations is -- PO_Service_Entries on return. end if; - - if Runtime_Traces then - - -- ??? Entry_Call can be null - - Send_Trace_Info (PO_Done, Entry_Call.Self); - end if; end Exceptional_Complete_Entry_Body; -------------------- @@ -439,11 +429,6 @@ package body System.Tasking.Protected_Objects.Operations is Object.Call_In_Progress := Entry_Call; begin - if Runtime_Traces then - Send_Trace_Info (PO_Run, Self_ID, - Entry_Call.Self, Entry_Index (E)); - end if; - pragma Debug (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); @@ -562,10 +547,6 @@ package body System.Tasking.Protected_Objects.Operations is pragma Debug (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); - if Runtime_Traces then - Send_Trace_Info (PO_Call, Entry_Index (E)); - end if; - if Self_ID.ATC_Nesting_Level = ATC_Level'Last then raise Storage_Error with "not enough ATC nesting levels"; end if; @@ -981,10 +962,6 @@ package body System.Tasking.Protected_Objects.Operations is raise Program_Error with "potentially blocking operation"; end if; - if Runtime_Traces then - Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); - end if; - Initialization.Defer_Abort_Nestable (Self_Id); Lock_Entries_With_Status (Object, Ceiling_Violation); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 16f4f340b68..241e6fe8dcc 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -575,6 +575,12 @@ package body Sem_Ch7 is -- i.e. not just syntactic, and the gain would very likely be worth -- neither the hassle nor the slowdown of the compiler. + -- Finally, an important thing to be aware of is that, at this point, + -- instantiations are not done yet so we cannot directly see inlined + -- bodies coming from them. That's not catastrophic because only the + -- actual parameters of the instantiations matter here, and they are + -- present in the declarations list of the instantiated packages. + Subprogram_Table.Reset; Discard := Has_Referencer (Decls, Top_Level => True); end Hide_Public_Entities; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6d838b3697c..0354db7aa17 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -15825,6 +15825,11 @@ package body Sem_Prag is elsif Nkind (Context) = N_Subprogram_Declaration then Id := Defining_Entity (Context); + + -- Pragma Ghost applies to a generic subprogram + + elsif Nkind (Context) = N_Generic_Subprogram_Declaration then + Id := Defining_Entity (Specification (Context)); end if; end if; -- 2.30.2