From ff7cce69d51cd9240c0fcb4e0379a670fdc1ad73 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 16 Jun 2005 10:49:41 +0200 Subject: [PATCH] 2005-06-14 Arnaud Charlet Jose Ruiz * s-tposen.adb, s-tpobop.adb (Exceptional_Complete_Rendezvous): Save the occurrence and not only the exception id. (PO_Do_Or_Queue): Before queuing a task on an entry queue we check that there is no violation of the Max_Entry_Queue_Length restriction (if it has been set); Program_Error is raised otherwise. (Requeue_Call): Before requeuing the task on the target entry queue we check that there is no violation of the Max_Entry_Queue_Length restriction (if it has been set); Program_Error is raised otherwise. From-SVN: r101064 --- gcc/ada/s-tpobop.adb | 79 ++++++++++++++++++++++++++++++++++++++++---- gcc/ada/s-tposen.adb | 40 +++++++++++++--------- 2 files changed, 97 insertions(+), 22 deletions(-) diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 3ab51b542c8..057b60d0dc7 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -1,8 +1,9 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- O P E R A T I O N S -- -- -- -- B o d y -- -- -- @@ -93,6 +94,9 @@ with System.Parameters; with System.Traces.Tasking; -- used for Send_Trace_Info +with System.Restrictions; +-- used for Run_Time_Restrictions + package body System.Tasking.Protected_Objects.Operations is package STPO renames System.Task_Primitives.Operations; @@ -102,6 +106,8 @@ package body System.Tasking.Protected_Objects.Operations is use Ada.Exceptions; use Entries; + use System.Restrictions; + use System.Restrictions.Rident; use System.Traces; use System.Traces.Tasking; @@ -265,6 +271,11 @@ package body System.Tasking.Protected_Objects.Operations is (Object : Protection_Entries_Access; Ex : Ada.Exceptions.Exception_Id) is + procedure Transfer_Occurrence + (Target : Ada.Exceptions.Exception_Occurrence_Access; + Source : Ada.Exceptions.Exception_Occurrence); + pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; begin pragma Debug @@ -278,6 +289,12 @@ package body System.Tasking.Protected_Objects.Operations is Entry_Call.Exception_To_Raise := Ex; + if Ex /= Ada.Exceptions.Null_Id then + Transfer_Occurrence + (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, + STPO.Self.Common.Compiler_Data.Current_Excep); + end if; + -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or -- PO_Service_Entries on return. end if; @@ -352,9 +369,32 @@ package body System.Tasking.Protected_Objects.Operations is elsif Entry_Call.Mode /= Conditional_Call or else not With_Abort then - Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, With_Abort); + 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)) + then + -- This violates the Max_Entry_Queue_Length restriction, + -- raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + 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); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + else + Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, With_Abort); + end if; else -- Conditional_Call and With_Abort @@ -734,9 +774,34 @@ package body System.Tasking.Protected_Objects.Operations is or else Entry_Call.Mode /= Conditional_Call then E := Protected_Entry_Index (Entry_Call.E); - Queuing.Enqueue - (New_Object.Entry_Queues (E), Entry_Call); - Update_For_Queue_To_PO (Entry_Call, With_Abort); + + 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)) + then + -- This violates the Max_Entry_Queue_Length restriction, + -- raise Program_Error. + + Entry_Call.Exception_To_Raise := Program_Error'Identity; + + 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); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + else + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, With_Abort); + end if; else PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort); diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index ded8d8401b9..23fdd1443a6 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -1,10 +1,11 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- S I N G L E _ E N T R Y -- -- -- --- B o d y -- +-- B o d y -- -- -- -- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- -- -- @@ -37,16 +38,16 @@ pragma Style_Checks (All_Checks); -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: --- --- PO have only one entry --- There is only one caller at a time (No_Entry_Queue) --- There is no dynamic priority support (No_Dynamic_Priorities) --- No Abort Statements --- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) --- PO are at library level --- No Requeue --- None of the tasks will terminate (no need for finalization) --- + +-- PO has only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- No Requeue +-- None of the tasks will terminate (no need for finalization) + -- This interface is intended to be used in the ravenscar and restricted -- profiles, the compiler is responsible for ensuring that the conditions -- mentioned above are respected, except for the No_Entry_Queue restriction @@ -492,7 +493,17 @@ package body System.Tasking.Protected_Objects.Single_Entry is end if; elsif Entry_Call.Mode /= Conditional_Call then - Object.Entry_Queue := Entry_Call; + if Object.Entry_Queue /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Self_Id, Entry_Call); + return; + else + Object.Entry_Queue := Entry_Call; + end if; + else -- Conditional_Call @@ -755,7 +766,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is Object.Owner := Null_Task; - Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting - 1; end; -- 2.30.2