[Ada] Ada2020: AI12-0117 Restriction No_Tasks_Unassigned_To_CPU

Message ID 20200716092051.GA146602@adacore.com
State New
Headers show
Series
  • [Ada] Ada2020: AI12-0117 Restriction No_Tasks_Unassigned_To_CPU
Related show

Commit Message

Pierre-Marie de Rodat July 16, 2020, 9:20 a.m.
Implement the No_Tasks_Unassigned_To_CPU restriction.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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.