[multiple changes]

2017-01-06  Ed Schonberg  <schonberg@adacore.com>

	* checks.adb (Ensure_Valid): Do not generate a validity check
	within a generated predicate function, validity checks will have
	been applied earlier when required.

2017-01-06  Tristan Gingold  <gingold@adacore.com>

	* s-tpoben.ads (Protection_Entries): Add comment and reorder
	components for performances.
	* s-tpobop.adb (PO_Do_Or_Queue): Implement Max_Queue_Length runtime
	semantic.

From-SVN: r244136

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1dc5958170177d5fb7f4ecb603b27a996de40139..ce482e34e0ed8a44d5f1ac987a9fd6cfaf425093 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2017-01-06  Ed Schonberg  <schonberg@adacore.com>
+
+       * checks.adb (Ensure_Valid): Do not generate a validity check
+       within a generated predicate function, validity checks will have
+       been applied earlier when required.
+
+2017-01-06  Tristan Gingold  <gingold@adacore.com>
+
+       * s-tpoben.ads (Protection_Entries): Add comment and reorder
+       components for performances.
+       * s-tpobop.adb (PO_Do_Or_Queue): Implement Max_Queue_Length runtime
+       semantic.
+
 2017-01-06  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_eval.adb (Check_Expression_Against_Static_Predicate):

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index efb36840185d590a4e579bed0aeed0bba9b37573..61e1ad4fed977be58d1c22f8832b832c07baf30b 100644 (file)
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -5709,6 +5709,14 @@ package body Checks is
       elsif Expr_Known_Valid (Expr) then
          return;
 
+      --  No check needed within a generated predicate function. Validity
+      --  of input value will have been checked earlier.
+
+      elsif Ekind (Current_Scope) = E_Function
+        and then Is_Predicate_Function (Current_Scope)
+      then
+         return;
+
       --  Ignore case of enumeration with holes where the flag is set not to
       --  worry about holes, since no special validity check is needed
 

diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads
index d069ebc58664b0af0aa736470c4b1b46d7eeedbc..90bfa89f3983d4fe5a2519f6471865a0da7a62d3 100644 (file)
--- a/gcc/ada/s-tpoben.ads
+++ b/gcc/ada/s-tpoben.ads
@@ -148,8 +148,6 @@ package System.Tasking.Protected_Objects.Entries is
       --  A function which maps the entry index in a call (which denotes the
       --  queue of the proper entry) into the body of the entry.
 
-      Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
-
       Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access;
       --  Access to an array of naturals representing the max value for each
       --  entry's queue length. A value of 0 signifies no max.
@@ -158,6 +156,9 @@ package System.Tasking.Protected_Objects.Entries is
       --  An array of string names which denotes entry [family member] names.
       --  The structure is indexed by protected entry index and contains Num_
       --  Entries components.
+
+      Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+      --  Action and barrier subprograms for the protected type.
    end record;
 
    --  No default initial values for this type, since call records will need to

diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index e242bb062831dab2f0c4c7a2ca2956baeb7a475a..a6f6c993d4e927ac135d5476b7e2f88c5f598d80 100644 (file)
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -292,17 +292,17 @@ package body System.Tasking.Protected_Objects.Operations is
    is
       E             : constant Protected_Entry_Index :=
                         Protected_Entry_Index (Entry_Call.E);
+      Index         : constant Protected_Entry_Index :=
+                        Object.Find_Body_Index (Object.Compiler_Info, E);
       Barrier_Value : Boolean;
-
+      Queue_Length  : Natural;
    begin
       --  When the Action procedure for an entry body returns, it is either
       --  completed (having called [Exceptional_]Complete_Entry_Body) or it
       --  is queued, having executed a requeue statement.
 
       Barrier_Value :=
-        Object.Entry_Bodies (
-          Object.Find_Body_Index (Object.Compiler_Info, E)).
-            Barrier (Object.Compiler_Info, E);
+        Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E);
 
       if Barrier_Value then
 
@@ -316,8 +316,7 @@ package body System.Tasking.Protected_Objects.Operations is
 
          pragma Debug
           (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
-         Object.Entry_Bodies (
-           Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
+         Object.Entry_Bodies (Index).Action (
              Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
 
          if Object.Call_In_Progress /= null then
@@ -346,29 +345,48 @@ package body System.Tasking.Protected_Objects.Operations is
         or else not Entry_Call.With_Abort
       then
          if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
-           and then Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
-                      Queuing.Count_Waiting (Object.Entry_Queues (E))
+           or else Object.Entry_Queue_Maxes /= null
          then
-            --  This violates the Max_Entry_Queue_Length restriction, raise
-            --  Program_Error.
+            --  Need to check the queue length. Computing the length is an
+            --  unusual case and is slow (need to walk the queue)
+
+            Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E));
+
+            if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
+                and then Queue_Length >=
+                   Run_Time_Restrictions.Value (Max_Entry_Queue_Length))
+              or else
+              (Object.Entry_Queue_Maxes /= null
+                 and then Object.Entry_Queue_Maxes (Index) /= 0
+                 and then Queue_Length >= Object.Entry_Queue_Maxes (Index))
+            then
+               --  This violates the Max_Entry_Queue_Length restriction or the
+               --  Max_Queue_Length bound, raise Program_Error.
 
-            Entry_Call.Exception_To_Raise := Program_Error'Identity;
+               Entry_Call.Exception_To_Raise := Program_Error'Identity;
 
-            if Single_Lock then
-               STPO.Lock_RTS;
-            end if;
+               if Single_Lock then
+                  STPO.Lock_RTS;
+               end if;
 
-            STPO.Write_Lock (Entry_Call.Self);
-            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
-            STPO.Unlock (Entry_Call.Self);
+               STPO.Write_Lock (Entry_Call.Self);
+               Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
+               STPO.Unlock (Entry_Call.Self);
 
-            if Single_Lock then
-               STPO.Unlock_RTS;
+               if Single_Lock then
+                  STPO.Unlock_RTS;
+               end if;
+
+               return;
             end if;
-         else
-            Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
-            Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
          end if;
+
+         --  Do the work: queue the call
+
+         Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
+         Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
+
+         return;
       else
          --  Conditional_Call and With_Abort