diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/s-tpobop.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/s-tpobop.adb | 1106 |
1 files changed, 1106 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/s-tpobop.adb b/gcc-4.8.3/gcc/ada/s-tpobop.adb new file mode 100644 index 000000000..aaf18208e --- /dev/null +++ b/gcc-4.8.3/gcc/ada/s-tpobop.adb @@ -0,0 +1,1106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all extended primitives related to Protected_Objects +-- with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- This package contains all primitives related to Protected_Objects. +-- Note: the compiler generates direct calls to this interface, via Rtsfind. + +with System.Task_Primitives.Operations; +with System.Tasking.Entry_Calls; +with System.Tasking.Queuing; +with System.Tasking.Rendezvous; +with System.Tasking.Utilities; +with System.Tasking.Debug; +with System.Parameters; +with System.Traces.Tasking; +with System.Restrictions; + +with System.Tasking.Initialization; +pragma Elaborate_All (System.Tasking.Initialization); +-- Insures that tasking is initialized if any protected objects are created + +package body System.Tasking.Protected_Objects.Operations is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Ada.Exceptions; + use Entries; + + use System.Restrictions; + use System.Restrictions.Rident; + use System.Traces; + use System.Traces.Tasking; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + pragma Inline (Update_For_Queue_To_PO); + -- Update the state of an existing entry call to reflect the fact that it + -- is being enqueued, based on whether the current queuing action is with + -- or without abort. Call this only while holding the PO's lock. It returns + -- with the PO's lock still held. + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link); + -- Handle requeue of Entry_Call. + -- In particular, queue the call if needed, or service it immediately + -- if possible. + + --------------------------------- + -- Cancel_Protected_Entry_Call -- + --------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- This should have analogous effect to Cancel_Task_Entry_Call, setting + -- the value of Block.Cancelled instead of returning the parameter value + -- Cancelled. + + -- The effect should be idempotent, since the call may already have been + -- dequeued. + + -- Source code: + + -- select r.e; + -- ...A... + -- then abort + -- ...B... + -- end select; + + -- Expanded code: + + -- declare + -- X : protected_entry_index := 1; + -- B80b : communication_block; + -- communication_blockIP (B80b); + + -- begin + -- begin + -- A79b : label + -- A79b : declare + -- procedure _clean is + -- begin + -- if enqueued (B80b) then + -- cancel_protected_entry_call (B80b); + -- end if; + -- return; + -- end _clean; + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, asynchronous_call, B80b, objectF => 0); + -- if enqueued (B80b) then + -- ...B... + -- end if; + -- at end + -- _clean; + -- end A79b; + + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- null; + -- end; + + -- if not cancelled (B80b) then + -- x := ...A... + -- end if; + -- end; + + -- If the entry call completes after we get into the abortable part, + -- Abort_Signal should be raised and ATC will take us to the at-end + -- handler, which will call _clean. + + -- If the entry call returns with the call already completed, we can skip + -- this, and use the "if enqueued()" to go past the at-end handler, but we + -- will still call _clean. + + -- If the abortable part completes before the entry call is Done, it will + -- call _clean. + + -- If the entry call or the abortable part raises an exception, + -- we will still call _clean, but the value of Cancelled should not matter. + + -- Whoever calls _clean first gets to decide whether the call + -- has been "cancelled". + + -- Enqueued should be true if there is any chance that the call is still on + -- a queue. It seems to be safe to make it True if the call was Onqueue at + -- some point before return from Protected_Entry_Call. + + -- Cancelled should be true iff the abortable part completed + -- and succeeded in cancelling the entry call before it completed. + + -- ????? + -- The need for Enqueued is less obvious. The "if enqueued ()" tests are + -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call + -- must do the same test internally, with locking. The one that makes + -- cancellation conditional may be a useful heuristic since at least 1/2 + -- the time the call should be off-queue by that point. The other one seems + -- totally useless, since Protected_Entry_Call must do the same check and + -- then possibly wait for the call to be abortable, internally. + + -- We can check Call.State here without locking the caller's mutex, + -- since the call must be over after returning from Wait_For_Completion. + -- No other task can access the call record at this point. + + procedure Cancel_Protected_Entry_Call + (Block : in out Communication_Block) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); + end Cancel_Protected_Entry_Call; + + --------------- + -- Cancelled -- + --------------- + + function Cancelled (Block : Communication_Block) return Boolean is + begin + return Block.Cancelled; + end Cancelled; + + ------------------------- + -- Complete_Entry_Body -- + ------------------------- + + procedure Complete_Entry_Body (Object : Protection_Entries_Access) is + begin + Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); + end Complete_Entry_Body; + + -------------- + -- Enqueued -- + -------------- + + function Enqueued (Block : Communication_Block) return Boolean is + begin + return Block.Enqueued; + end Enqueued; + + ------------------------------------- + -- Exceptional_Complete_Entry_Body -- + ------------------------------------- + + procedure Exceptional_Complete_Entry_Body + (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; + Self_Id : Task_Id; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); + + -- We must have abort deferred, since we are inside a protected + -- operation. + + if Entry_Call /= null then + + -- The call was not requeued + + Entry_Call.Exception_To_Raise := Ex; + + if Ex /= Ada.Exceptions.Null_Id then + + -- An exception was raised and abort was deferred, so adjust + -- before propagating, otherwise the task will stay with deferral + -- enabled for its remaining life. + + Self_Id := STPO.Self; + + if not ZCX_By_Default then + Initialization.Undefer_Abort_Nestable (Self_Id); + end if; + + Transfer_Occurrence + (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, + Self_Id.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; + + if Runtime_Traces then + + -- ??? Entry_Call can be null + + Send_Trace_Info (PO_Done, Entry_Call.Self); + end if; + end Exceptional_Complete_Entry_Body; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_ID : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + E : constant Protected_Entry_Index := + Protected_Entry_Index (Entry_Call.E); + Barrier_Value : Boolean; + + 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); + + if Barrier_Value then + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + pragma Debug + (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)).Action ( + Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + if Object.Call_In_Progress /= null then + + -- Body of current entry served call to completion + + Object.Call_In_Progress := null; + + 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 + Requeue_Call (Self_ID, Object, Entry_Call); + end if; + + elsif Entry_Call.Mode /= Conditional_Call + 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)) + 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, Entry_Call.With_Abort); + end if; + else + -- Conditional_Call and With_Abort + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + pragma Assert (Entry_Call.State /= Not_Yet_Abortable); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + exception + when others => + Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); + end PO_Do_Or_Queue; + + ------------------------ + -- PO_Service_Entries -- + ------------------------ + + procedure PO_Service_Entries + (Self_ID : Task_Id; + Object : Entries.Protection_Entries_Access; + Unlock_Object : Boolean := True) + is + E : Protected_Entry_Index; + Caller : Task_Id; + Entry_Call : Entry_Call_Link; + + begin + loop + Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); + + exit when Entry_Call = null; + + E := Protected_Entry_Index (Entry_Call.E); + + -- Not abortable while service is in progress + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + begin + if Runtime_Traces then + Send_Trace_Info (PO_Run, Self_ID, + Entry_Call.Self, Entry_Index (E)); + end if; + + pragma Debug + (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); + + Object.Entry_Bodies + (Object.Find_Body_Index (Object.Compiler_Info, E)).Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + exception + when others => + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end; + + if Object.Call_In_Progress = null then + Requeue_Call (Self_ID, Object, Entry_Call); + exit when Entry_Call.State = Cancelled; + + else + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + end loop; + + if Unlock_Object then + Unlock_Entries (Object); + end if; + end PO_Service_Entries; + + --------------------- + -- Protected_Count -- + --------------------- + + function Protected_Count + (Object : Protection_Entries'Class; + E : Protected_Entry_Index) return Natural + is + begin + return Queuing.Count_Waiting (Object.Entry_Queues (E)); + end Protected_Count; + + -------------------------- + -- Protected_Entry_Call -- + -------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- select r.e; + -- ...A... + -- else + -- ...B... + -- end select; + + -- declare + -- X : protected_entry_index := 1; + -- B85b : communication_block; + -- communication_blockIP (B85b); + + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, conditional_call, B85b, objectF => 0); + + -- if cancelled (B85b) then + -- ...B... + -- else + -- ...A... + -- end if; + -- end; + + -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous + -- entry call. + + -- The initial part of this procedure does not need to lock the calling + -- task's ATCB, up to the point where the call record first may be queued + -- (PO_Do_Or_Queue), since before that no other task will have access to + -- the record. + + -- If this is a call made inside of an abort deferred region, the call + -- should be never abortable. + + -- If the call was not queued abortably, we need to wait until it is before + -- proceeding with the abortable part. + + -- There are some heuristics here, just to save time for frequently + -- occurring cases. For example, we check Initially_Abortable to try to + -- avoid calling the procedure Wait_Until_Abortable, since the normal case + -- for async. entry calls is to be queued abortably. + + -- Another heuristic uses the Block.Enqueued to try to avoid calling + -- Cancel_Protected_Entry_Call if the call can be served immediately. + + procedure Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Initially_Abortable : Boolean; + Ceiling_Violation : Boolean; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); + + if Runtime_Traces then + Send_Trace_Info (PO_Call, Entry_Index (E)); + end if; + + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + -- Self_ID.Deferral_Level should be 0, except when called from Finalize, + -- where abort is already deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + + -- Failed ceiling check + + Initialization.Undefer_Abort_Nestable (Self_ID); + raise Program_Error; + end if; + + Block.Self := Self_ID; + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: entered ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call := + Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_ID.Deferral_Level > 1 + then Never_Abortable else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call); + Initially_Abortable := Entry_Call.State = Now_Abortable; + PO_Service_Entries (Self_ID, Object); + + -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) + -- for completed or cancelled calls. (This is a heuristic, only.) + + if Entry_Call.State >= Done then + + -- Once State >= Done it will not change any more + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_ID); + Utilities.Exit_One_ATC_Level (Self_ID); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Block.Enqueued := False; + Block.Cancelled := Entry_Call.State = Cancelled; + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + + else + -- In this case we cannot conclude anything, since State can change + -- concurrently. + + null; + end if; + + -- Now for the general case + + if Mode = Asynchronous_Call then + + -- Try to avoid an expensive call + + if not Initially_Abortable then + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + STPO.Unlock_RTS; + else + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; + end if; + + else + case Mode is + when Simple_Call | Conditional_Call => + if Single_Lock then + STPO.Lock_RTS; + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock_RTS; + + else + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Entry_Call); + STPO.Unlock (Self_ID); + end if; + + Block.Cancelled := Entry_Call.State = Cancelled; + + when Asynchronous_Call | Timed_Call => + pragma Assert (False); + null; + end case; + end if; + + Initialization.Undefer_Abort_Nestable (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end Protected_Entry_Call; + + ------------------ + -- Requeue_Call -- + ------------------ + + procedure Requeue_Call + (Self_Id : Task_Id; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link) + is + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Result : Boolean; + E : Protected_Entry_Index; + + begin + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if Single_Lock then + STPO.Lock_RTS; + end if; + + Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); + + if not Result then + Queuing.Broadcast_Program_Error + (Self_Id, Object, Entry_Call, RTS_Locked => True); + end if; + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + + -- Requeue is to different PO + + Lock_Entries_With_Status (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + PO_Service_Entries (Self_Id, New_Object); + end if; + + else + -- Requeue is to same protected object + + -- ??? Try to compensate apparent failure of the scheduler on some + -- OS (e.g VxWorks) to give higher priority tasks a chance to run + -- (see CXD6002). + + STPO.Yield (Do_Yield => False); + + if Entry_Call.With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried to cancel + -- this call, cancel it at this point. + + Entry_Call.State := Cancelled; + return; + end if; + + if not Entry_Call.With_Abort + or else Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + + 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, Entry_Call.With_Abort); + end if; + + else + PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); + end if; + end if; + end if; + end Requeue_Call; + + ---------------------------- + -- Protected_Entry_Caller -- + ---------------------------- + + function Protected_Entry_Caller + (Object : Protection_Entries'Class) return Task_Id is + begin + return Object.Call_In_Progress.Self; + end Protected_Entry_Caller; + + ----------------------------- + -- Requeue_Protected_Entry -- + ----------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- entry e when b is + -- begin + -- b := false; + -- ...A... + -- requeue e2; + -- end e; + + -- procedure rPT__E10b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_entry (rR'unchecked_access, rR' + -- unchecked_access, 2, false, objectF => 0, new_objectF => + -- 0); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E10b; + + procedure Requeue_Protected_Entry + (Object : Protection_Entries_Access; + New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_Entry; + + ------------------------------------- + -- Requeue_Task_To_Protected_Entry -- + ------------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + -- accept e1 do + -- ...A... + -- requeue r.e2; + -- end e1; + + -- A79b : address; + -- L78b : label + + -- begin + -- accept_call (1, A79b); + -- ...A... + -- requeue_task_to_protected_entry (rTV!(r)._object' + -- unchecked_access, 2, false, new_objectF => 0); + -- goto L78b; + -- <<L78b>> + -- complete_rendezvous; + + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Self_ID : constant Task_Id := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; + + begin + Initialization.Defer_Abort (Self_ID); + + -- We do not need to lock Self_ID here since the call is not abortable + -- at this point, and therefore, the caller cannot cancel the call. + + Entry_Call.Needs_Requeue := True; + Entry_Call.With_Abort := With_Abort; + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.E := Entry_Index (E); + Initialization.Undefer_Abort (Self_ID); + end Requeue_Task_To_Protected_Entry; + + --------------------- + -- Service_Entries -- + --------------------- + + procedure Service_Entries (Object : Protection_Entries_Access) is + Self_ID : constant Task_Id := STPO.Self; + begin + PO_Service_Entries (Self_ID, Object); + end Service_Entries; + + -------------------------------- + -- Timed_Protected_Entry_Call -- + -------------------------------- + + -- Compiler interface only (do not call from within the RTS) + + procedure Timed_Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_Id : constant Task_Id := STPO.Self; + Entry_Call : Entry_Call_Link; + Ceiling_Violation : Boolean; + + Yielded : Boolean; + pragma Unreferenced (Yielded); + + begin + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + raise Storage_Error with "not enough ATC nesting levels"; + end if; + + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + raise Program_Error with "potentially blocking operation"; + end if; + + if Runtime_Traces then + Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); + end if; + + Initialization.Defer_Abort_Nestable (Self_Id); + Lock_Entries_With_Status (Object, Ceiling_Violation); + + if Ceiling_Violation then + Initialization.Undefer_Abort (Self_Id); + raise Program_Error; + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + Entry_Call.State := + (if Self_Id.Deferral_Level > 1 + then Never_Abortable + else Now_Abortable); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + Entry_Call.With_Abort := True; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call); + PO_Service_Entries (Self_Id, Object); + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + -- Try to avoid waiting for completed or cancelled calls + + if Entry_Call.State >= Done then + Utilities.Exit_One_ATC_Level (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + Entry_Call_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + return; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Entry_Call, Timeout, Mode, Yielded); + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + -- ??? Do we need to yield in case Yielded is False + + Initialization.Undefer_Abort_Nestable (Self_Id); + Entry_Call_Successful := Entry_Call.State = Done; + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Protected_Entry_Call; + + ---------------------------- + -- Update_For_Queue_To_PO -- + ---------------------------- + + -- Update the state of an existing entry call, based on + -- whether the current queuing action is with or without abort. + -- Call this only while holding the server's lock. + -- It returns with the server's lock released. + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + Old : constant Entry_Call_State := Entry_Call.State; + + begin + pragma Assert (Old < Done); + + Entry_Call.State := New_State (With_Abort, Entry_Call.State); + + if Entry_Call.Mode = Asynchronous_Call then + if Old < Was_Abortable and then + Entry_Call.State = Now_Abortable + then + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + end if; + + elsif Entry_Call.Mode = Conditional_Call then + pragma Assert (Entry_Call.State < Was_Abortable); + null; + end if; + end Update_For_Queue_To_PO; + +end System.Tasking.Protected_Objects.Operations; |