Fix nternal compiler error for Sequential Partition_Elaboration_Policy

In some cases, compilation of a function with a limited class-wide result
type could fail with an ICE if a Sequential Partition_Elaboration_Policy is
specified. To prevent this, we really want that specifying a Sequential
Partition_Elaboration_Policy to have the side effect of imposing a
No_Task_Hierarchy restriction. But doing that in a straightforward
way leads to problems with incorrectly accepting violations of H.6(6).
So a new restriction, No_Task_Hierarchy_Implicit, is introduced.

gcc/ada/
	PR ada/104354
	* libgnat/s-rident.ads: Define a new restriction,
	No_Task_Hierarchy_Implicit. This is like the No_Task_Hierarchy
	restriction, but with the difference that setting this restriction
	does not mean the H.6(6) post-compilation check is satisified.
	* exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): If it is
	known that the function result cannot have tasks, then pass in a
	null literal for the activation chain actual parameter. This
	avoids generating a reference to an entity that
	Build_Activation_Chain_Entity may have chosen not to generate a
	declaration for.
	* gnatbind.adb (List_Applicable_Restrictions): Do not list the
	No_Task_Hierarchy_Implicit restriction.
	* restrict.adb: Special treatment for the
	No_Task_Hierarchy_Implicit restriction in functions
	Get_Restriction_Id and Restriction_Active. The former is needed to
	disallow the (unlikely) case that a user tries to explicitly
	reference the No_Task_Hierarchy_Implicit restriction.
	* sem_prag.adb (Analyze_Pragma): If a Sequential
	Partition_Elaboration_Policy is specified (and the
	No_Task_Hierarchy restriction is not already enabled), then enable
	the No_Task_Hierarchy_Implicit restriction.

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 24476194337a01eb03f9949aa42dc2953077319b..35afb95347be6fce76682667373b8996977f368f 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -630,7 +630,10 @@ package body Exp_Ch6 is
 
       --  Create the actual which is a pointer to the current activation chain
 
-      if No (Chain) then
+      if Restriction_Active (No_Task_Hierarchy) then
+         Chain_Actual := Make_Null (Loc);
+
+      elsif No (Chain) then
          Chain_Actual :=
            Make_Attribute_Reference (Loc,
              Prefix         => Make_Identifier (Loc, Name_uChain),

diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 4c50e61617da3a1f3f8519390b40b99d93b7abb8..c30c6353154181432f4118e7df61925bddf84612 100644 (file)
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -214,6 +214,9 @@ procedure Gnatbind is
          No_Specification_Of_Aspect      => False,
          --  Requires a parameter value, not a count
 
+         No_Task_Hierarchy_Implicit      => False,
+         --  A compiler implementation artifact, not a documented restriction
+
          No_Use_Of_Attribute             => False,
          --  Requires a parameter value, not a count
 

diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads
index d3a84e3471abe3db08da70465a48528f30999e60..bf2cf81a525d193e6ddace2ca4595cc00641ca7e 100644 (file)
--- a/gcc/ada/libgnat/s-rident.ads
+++ b/gcc/ada/libgnat/s-rident.ads
@@ -106,7 +106,7 @@ package System.Rident is
       No_Dispatching_Calls,                      -- GNAT
       No_Dynamic_Accessibility_Checks,           -- GNAT
       No_Dynamic_Attachment,                     -- Ada 2012 (RM E.7(10/3))
-      No_Dynamic_CPU_Assignment,                 -- Ada 202x (RM D.7(10/3))
+      No_Dynamic_CPU_Assignment,                 -- Ada 2022 (RM D.7(10/3))
       No_Dynamic_Priorities,                     -- (RM D.9(9))
       No_Enumeration_Maps,                       -- GNAT
       No_Entry_Calls_In_Elaboration_Code,        -- GNAT
@@ -150,8 +150,9 @@ package System.Rident is
       No_Task_Attributes_Package,                -- GNAT
       No_Task_At_Interrupt_Priority,             -- GNAT
       No_Task_Hierarchy,                         -- (RM D.7(3), H.4(3))
-      No_Task_Termination,                       -- GNAT (Ravenscar)
-      No_Tasks_Unassigned_To_CPU,                -- Ada 202x (D.7(10.10/4))
+      No_Task_Hierarchy_Implicit,                -- GNAT
+      No_Task_Termination,                       -- Ada 2005 (D.7(15.1/2))
+      No_Tasks_Unassigned_To_CPU,                -- Ada 2022 (D.7(10.10/4))
       No_Tasking,                                -- GNAT
       No_Terminate_Alternatives,                 -- (RM D.7(6))
       No_Unchecked_Access,                       -- (RM H.4(18))

diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index d62572ef54b5c395dfc7b260d92464b1ba24b88e..e707c04eaabd27bb30a043cc3e5ab8c6003b711f 100644 (file)
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -886,7 +886,10 @@ package body Restrict is
          declare
             S : constant String := Restriction_Id'Image (J);
          begin
-            if S = Name_Buffer (1 .. Name_Len) then
+            if S = Name_Buffer (1 .. Name_Len)
+              --  users cannot name the N_T_H_Implicit restriction
+              and then J /= No_Task_Hierarchy_Implicit
+            then
                return J;
             end if;
          end;
@@ -1093,7 +1096,12 @@ package body Restrict is
 
    function Restriction_Active (R : All_Restrictions) return Boolean is
    begin
-      return Restrictions.Set (R) and then not Restriction_Warnings (R);
+      if Restrictions.Set (R) and then not Restriction_Warnings (R) then
+         return True;
+      else
+         return R = No_Task_Hierarchy
+           and then Restriction_Active (No_Task_Hierarchy_Implicit);
+      end if;
    end Restriction_Active;
 
    --------------------------------

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index f9169eeedd7de415e11ec6cc71035d6e64332241..81b0942279284793da730ee0183e6ecdc505a6df 100644 (file)
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -21102,6 +21102,25 @@ package body Sem_Prag is
                if Partition_Elaboration_Policy_Sloc /= System_Location then
                   Partition_Elaboration_Policy_Sloc := Loc;
                end if;
+
+               if PEP_Val = Name_Sequential
+                 and then not Restriction_Active (No_Task_Hierarchy)
+               then
+                  --  RM H.6(6) guarantees that No_Task_Hierarchy will be
+                  --  set eventually, so take advantage of that knowledge now.
+                  --  But we have to do this in a tricky way. If we simply
+                  --  set the No_Task_Hierarchy restriction here, then the
+                  --  assumption that the restriction will be set eventually
+                  --  becomes a self-fulfilling prophecy; the binder can
+                  --  then mistakenly conclude that the H.6(6) rule is
+                  --  satisified in cases where the post-compilation check
+                  --  should fail. So we invent a new restriction,
+                  --  No_Task_Hierarchy_Implicit, which is treated specially
+                  --  in the function Restriction_Active.
+
+                  Set_Restriction (No_Task_Hierarchy_Implicit, N);
+                  pragma Assert (Restriction_Active (No_Task_Hierarchy));
+               end if;
             end if;
          end PEP;