From 47484baae5aa2c74f1b65547f4436baa040b2728 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 11 Jun 2020 14:05:55 -0400 Subject: [PATCH] [Ada] Ada2020: AI12-0117 Restriction No_Tasks_Unassigned_To_CPU gcc/ada/ * gnatbind.adb (Gnatbind): For No_Tasks_Unassigned_To_CPU, check that CPU has been set on the main subprogram. (Restriction_Could_Be_Set): Don't print No_Tasks_Unassigned_To_CPU if it would violate the above-mentioned rule. Up to now, all restrictions were checked by the compiler, with the binder just checking for consistency. But the compiler can't know which subprogram is the main, so it's impossible to check this one at compile time. * restrict.ads, restrict.adb: Misc refactoring. Change Warning to Warn, for consistency, since most already use Warn. (Set_Restriction): New convenience routine. * sem_ch13.adb (Attribute_CPU): Check No_Tasks_Unassigned_To_CPU. * sem_prag.adb (Pragma_CPU): Check No_Tasks_Unassigned_To_CPU. Misc refactoring. * tbuild.ads, tbuild.adb (Sel_Comp): New functions for building selected components. --- gcc/ada/gnatbind.adb | 39 ++++++++--- gcc/ada/restrict.adb | 51 +++++++++----- gcc/ada/restrict.ads | 28 ++++++-- gcc/ada/sem_ch13.adb | 19 +++++- gcc/ada/sem_prag.adb | 156 ++++++++++++++----------------------------- gcc/ada/tbuild.adb | 17 +++++ gcc/ada/tbuild.ads | 5 ++ 7 files changed, 176 insertions(+), 139 deletions(-) diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 4372152b439..be087af63ea 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -238,8 +238,8 @@ procedure Gnatbind is ------------------------------ function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is - CR : Restrictions_Info renames Cumulative_Restrictions; - + CR : Restrictions_Info renames Cumulative_Restrictions; + Result : Boolean; begin case R is @@ -247,11 +247,19 @@ procedure Gnatbind is when All_Boolean_Restrictions => - -- The condition for listing a boolean restriction as an - -- additional restriction that could be set is that it is - -- not violated by any unit, and not already set. + -- Print it if not violated by any unit, and not already set... + + Result := not CR.Violated (R) and then not CR.Set (R); + + -- ...except that for No_Tasks_Unassigned_To_CPU, we don't want + -- to print it if it would violate the restriction post + -- compilation. - return CR.Violated (R) = False and then CR.Set (R) = False; + if R = No_Tasks_Unassigned_To_CPU + and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU + then + Result := False; + end if; -- Parameter restriction @@ -261,18 +269,18 @@ procedure Gnatbind is -- unknown, the restriction can definitely not be listed. if CR.Violated (R) and then CR.Unknown (R) then - return False; + Result := False; -- We can list the restriction if it is not set elsif not CR.Set (R) then - return True; + Result := True; -- We can list the restriction if is set to a greater value -- than the maximum value known for the violation. else - return CR.Value (R) > CR.Count (R); + Result := CR.Value (R) > CR.Count (R); end if; -- No other values for R possible @@ -280,6 +288,8 @@ procedure Gnatbind is when others => raise Program_Error; end case; + + return Result; end Restriction_Could_Be_Set; -- Start of processing for List_Applicable_Restrictions @@ -881,6 +891,17 @@ begin -- mode where we want to be more flexible. if not CodePeer_Mode then + -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": + -- If the restriction No_Tasks_Unassigned_To_CPU applies, then + -- check that the main subprogram has a CPU assigned. + + if Cumulative_Restrictions.Set (No_Tasks_Unassigned_To_CPU) + and then ALIs.Table (ALIs.First).Main_CPU = No_Main_CPU + then + Error_Msg ("No_Tasks_Unassigned_To_CPU restriction requires CPU" & + " aspect to be specified for main procedure"); + end if; + Check_Duplicated_Subunits; Check_Versions; Check_Consistency; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 08788d1de9e..5ba2931cfd9 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -1354,8 +1354,6 @@ package body Restrict is -- Set_Restriction -- --------------------- - -- Case of Boolean restriction - procedure Set_Restriction (R : All_Boolean_Restrictions; N : Node_Id) @@ -1395,8 +1393,6 @@ package body Restrict is end if; end Set_Restriction; - -- Case of parameter restriction - procedure Set_Restriction (R : All_Parameter_Restrictions; N : Node_Id; @@ -1446,6 +1442,29 @@ package body Restrict is Restriction_Profile_Name (R) := No_Profile; end Set_Restriction; + procedure Set_Restriction + (R : All_Restrictions; + N : Node_Id; + Warn : Boolean; + V : Integer := Integer'First) + is + Set : Boolean := True; + begin + if Warn and then Restriction_Active (R) then + Set := False; + end if; + + if Set then + if R in All_Boolean_Restrictions then + Set_Restriction (R, N); + else + Set_Restriction (R, N, V); + end if; + + Restriction_Warnings (R) := Warn; + end if; + end Set_Restriction; + ----------------------------------- -- Set_Restriction_No_Dependence -- ----------------------------------- @@ -1485,7 +1504,7 @@ package body Restrict is procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; - Warning : Boolean; + Warn : Boolean; Profile : Profile_Name := No_Profile) is Nam : Node_Id; @@ -1501,7 +1520,7 @@ package body Restrict is -- Error has precedence over warning - if not Warning then + if not Warn then No_Use_Of_Entity.Table (J).Warn := False; end if; @@ -1511,7 +1530,7 @@ package body Restrict is -- Entry is not currently in table - No_Use_Of_Entity.Append ((Entity, Warning, Profile)); + No_Use_Of_Entity.Append ((Entity, Warn, Profile)); -- Now we need to find the direct name and set Boolean2 flag @@ -1532,15 +1551,15 @@ package body Restrict is ------------------------------------------------ procedure Set_Restriction_No_Specification_Of_Aspect - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); begin No_Specification_Of_Aspect_Set := True; No_Specification_Of_Aspects (A_Id) := Sloc (N); - No_Specification_Of_Aspect_Warning (A_Id) := Warning; + No_Specification_Of_Aspect_Warning (A_Id) := Warn; end Set_Restriction_No_Specification_Of_Aspect; procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is @@ -1555,15 +1574,15 @@ package body Restrict is ----------------------------------------- procedure Set_Restriction_No_Use_Of_Attribute - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin No_Use_Of_Attribute_Set := True; No_Use_Of_Attribute (A_Id) := Sloc (N); - No_Use_Of_Attribute_Warning (A_Id) := Warning; + No_Use_Of_Attribute_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Attribute; procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is @@ -1578,15 +1597,15 @@ package body Restrict is -------------------------------------- procedure Set_Restriction_No_Use_Of_Pragma - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); begin No_Use_Of_Pragma_Set := True; No_Use_Of_Pragma (A_Id) := Sloc (N); - No_Use_Of_Pragma_Warning (A_Id) := Warning; + No_Use_Of_Pragma_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Pragma; procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a6384011399..7a84d3741c6 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -452,6 +452,20 @@ package Restrict is -- Similar to the above, except that this is used for the case of a -- parameter restriction, and the corresponding value V is given. + procedure Set_Restriction + (R : All_Restrictions; + N : Node_Id; + Warn : Boolean; + V : Integer := Integer'First); + -- Same as above two, except also takes care of setting the + -- Restriction_Warnings flag. V is ignored for Boolean + -- restrictions. + -- + -- If this is the first time we've seen this restriction, the warning flag + -- is set to Warn. If this is a second or subsequent time, Warn = False + -- wins; that is, errors always trump warnings. In that case, the warning + -- flag can be set to False, but never to True. + procedure Set_Restriction_No_Dependence (Unit : Node_Id; Warn : Boolean; @@ -463,8 +477,8 @@ package Restrict is -- No_Dependence restriction comes from a Profile pragma. procedure Set_Restriction_No_Specification_Of_Aspect - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for an identifier from a pragma Restrictions for the -- No_Specification_Of_Aspect pragma. An error message will be issued if -- the identifier is not a valid aspect name. Warning is set True for the @@ -475,8 +489,8 @@ package Restrict is -- Version used by Get_Target_Parameters (via Tbuild) procedure Set_Restriction_No_Use_Of_Attribute - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for the identifier in a pragma Restrictions for -- No_Use_Of_Attribute. Caller has verified that this is a valid attribute -- designator. @@ -486,7 +500,7 @@ package Restrict is procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; - Warning : Boolean; + Warn : Boolean; Profile : Profile_Name := No_Profile); -- Sets given No_Use_Of_Entity restriction in table if not there already. -- Warn is True if from Restriction_Warnings, or for Restrictions if the @@ -497,8 +511,8 @@ package Restrict is -- the entity (to optimize table searches). procedure Set_Restriction_No_Use_Of_Pragma - (N : Node_Id; - Warning : Boolean); + (N : Node_Id; + Warn : Boolean); -- N is the node id for the identifier in a pragma Restrictions for -- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9008b60dc15..5ed468e59fd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6464,7 +6464,24 @@ package body Sem_Ch13 is Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); Pop_Type (U_Ent); - if not Is_OK_Static_Expression (Expr) then + -- AI12-0117-1, "Restriction No_Tasks_Unassigned_To_CPU": + -- If the expression is static, and its value is + -- System.Multiprocessors.Not_A_Specific_CPU (i.e. zero) then + -- that's a violation of No_Tasks_Unassigned_To_CPU. It might + -- seem better to refer to Not_A_Specific_CPU here, but that + -- involves a lot of horsing around with Rtsfind, and this + -- value is not going to change, so it's better to hardwire + -- Uint_0. + -- + -- AI12-0055-1, "All properties of a usage profile are defined + -- by pragmas": If the expression is nonstatic, that's a + -- violation of No_Dynamic_CPU_Assignment. + + if Is_OK_Static_Expression (Expr) then + if Expr_Value (Expr) = Uint_0 then + Check_Restriction (No_Tasks_Unassigned_To_CPU, Expr); + end if; + else Check_Restriction (No_Dynamic_CPU_Assignment, Expr); end if; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 91c3d6d3bc6..eb8f2a0494f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10542,23 +10542,28 @@ package body Sem_Prag is Set_Global_No_Tasking; end if; - -- If this is a warning, then set the warning unless we already - -- have a real restriction active (we never want a warning to - -- override a real restriction). - - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := True; - end if; + Set_Restriction (R_Id, N, Warn); - -- If real restriction case, then set it and make sure that the - -- restriction warning flag is off, since a real restriction - -- always overrides a warning. + if R_Id = No_Dynamic_CPU_Assignment + or else R_Id = No_Tasks_Unassigned_To_CPU + then + -- These imply No_Dependence => + -- "System.Multiprocessors.Dispatching_Domains". + -- This is not strictly what the AI says, but it eliminates + -- the need for run-time checks, which are undesirable in + -- this context. - else - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := False; + Set_Restriction_No_Dependence + (Sel_Comp + (Sel_Comp ("system", "multiprocessors", Loc), + "dispatching_domains"), + Warn); + end if; + + if R_Id = No_Tasks_Unassigned_To_CPU then + -- Likewise, imply No_Dynamic_CPU_Assignment + + Set_Restriction (No_Dynamic_CPU_Assignment, N, Warn); end if; -- Check for obsolescent restrictions in Ada 2005 mode @@ -10702,26 +10707,7 @@ package body Sem_Prag is ("pragma ignored, value too large??", Arg); end if; - -- Warning case. If the real restriction is active, then we - -- ignore the request, since warning never overrides a real - -- restriction. Otherwise we set the proper warning. Note that - -- this circuit sets the warning again if it is already set, - -- which is what we want, since the constant may have changed. - - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction - (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := True; - end if; - - -- Real restriction case, set restriction and make sure warning - -- flag is off since real restriction always overrides warning. - - else - Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := False; - end if; + Set_Restriction (R_Id, N, Warn, Integer (UI_To_Int (Val))); end if; Next (Arg); @@ -11313,13 +11299,6 @@ package body Sem_Prag is Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); end Set_Error_Msg_To_Profile_Name; - -- Local variables - - Nod : Node_Id; - Pref : Node_Id; - Pref_Id : Node_Id; - Sel_Id : Node_Id; - Profile_Dispatching_Policy : Character; -- Start of processing for Set_Ravenscar_Profile @@ -11391,46 +11370,30 @@ package body Sem_Prag is -- No_Dependence => Ada.Calendar -- No_Dependence => Ada.Task_Attributes -- are already set by previous call to Set_Profile_Restrictions. + -- Really??? -- Set the following restrictions which were added to Ada 2005: -- No_Dependence => Ada.Execution_Time.Group_Budget -- No_Dependence => Ada.Execution_Time.Timers if Ada_Version >= Ada_2005 then - Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); - Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time")); - - Pref := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - - Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - - Set_Restriction_No_Dependence - (Unit => Nod, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); - - Sel_Id := Make_Identifier (Loc, Name_Find ("timers")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - - Set_Restriction_No_Dependence - (Unit => Nod, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); + declare + Execution_Time : constant Node_Id := + Sel_Comp ("ada", "execution_time", Loc); + Group_Budgets : constant Node_Id := + Sel_Comp (Execution_Time, "group_budgets"); + Timers : constant Node_Id := + Sel_Comp (Execution_Time, "timers"); + begin + Set_Restriction_No_Dependence + (Unit => Group_Budgets, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + Set_Restriction_No_Dependence + (Unit => Timers, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end; end if; -- Set the following restriction which was added to Ada 2012 (see @@ -11438,25 +11401,10 @@ package body Sem_Prag is -- No_Dependence => System.Multiprocessors.Dispatching_Domains if Ada_Version >= Ada_2012 then - Pref_Id := Make_Identifier (Loc, Name_Find ("system")); - Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors")); - - Pref := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - - Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref, - Selector_Name => Sel_Id); - Set_Restriction_No_Dependence - (Unit => Nod, + (Sel_Comp + (Sel_Comp ("system", "multiprocessors", Loc), + "dispatching_domains"), Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); @@ -11468,18 +11416,8 @@ package body Sem_Prag is -- in Ada2012 (AI05-0174). if Profile /= Jorvik then - Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); - Sel_Id := Make_Identifier (Loc, Name_Find - ("synchronous_barriers")); - - Nod := - Make_Selected_Component - (Sloc => Loc, - Prefix => Pref_Id, - Selector_Name => Sel_Id); - Set_Restriction_No_Dependence - (Unit => Nod, + (Sel_Comp ("ada", "synchronous_barriers", Loc), Warn => Treat_Restrictions_As_Warnings, Profile => Ravenscar); end if; @@ -14916,7 +14854,13 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); - if not Is_OK_Static_Expression (Arg) then + -- See comment in Sem_Ch13 about the following restrictions + + if Is_OK_Static_Expression (Arg) then + if Expr_Value (Arg) = Uint_0 then + Check_Restriction (No_Tasks_Unassigned_To_CPU, N); + end if; + else Check_Restriction (No_Dynamic_CPU_Assignment, N); end if; diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 212d31553dc..4feb3a23edb 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -797,6 +797,23 @@ package body Tbuild is return Result; end OK_Convert_To; + -------------- + -- Sel_Comp -- + -------------- + + function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id is + begin + return Make_Selected_Component + (Sloc => Sloc (Pre), + Prefix => Pre, + Selector_Name => Make_Identifier (Sloc (Pre), Name_Find (Sel))); + end Sel_Comp; + + function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id is + begin + return Sel_Comp (Make_Identifier (Loc, Name_Find (Pre)), Sel); + end Sel_Comp; + ------------- -- Set_NOD -- ------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 3256804de63..70bf653bd73 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -335,6 +335,11 @@ package Tbuild is -- fixed-point small is called typ_SMALL where typ is the name of the -- fixed-point type (as passed in Related_Id), and Suffix is "SMALL". + function Sel_Comp (Pre, Sel : String; Loc : Source_Ptr) return Node_Id; + function Sel_Comp (Pre : Node_Id; Sel : String) return Node_Id; + -- Create a selected component of the form Pre.Sel; that is, Pre is the + -- prefix, and Sel is the selector name. + function OK_Convert_To (Typ : Entity_Id; Expr : Node_Id) return Node_Id; -- Like Convert_To, except that a conversion node is always generated, and -- the Conversion_OK flag is set on this conversion node. -- 2.30.2