diff options
Diffstat (limited to 'gcc/ada/s-tpobop.adb')
| -rw-r--r-- | gcc/ada/s-tpobop.adb | 981 |
1 files changed, 981 insertions, 0 deletions
diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb new file mode 100644 index 00000000000..2e865821bc9 --- /dev/null +++ b/gcc/ada/s-tpobop.adb @@ -0,0 +1,981 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- 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 -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1991-2001, Florida State University -- +-- -- +-- 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 2, or (at your option) any later ver- -- +-- sion. GNARL 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all the 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 Ada.Exceptions; +-- Used for Exception_ID +-- Null_Id +-- Raise_Exception + +with System.Task_Primitives.Operations; +-- used for Initialize_Lock +-- Write_Lock +-- Unlock +-- Get_Priority +-- Wakeup + +with System.Tasking.Entry_Calls; +-- used for Wait_For_Completion +-- Wait_Until_Abortable + +with System.Tasking.Initialization; +-- Used for Defer_Abort, +-- Undefer_Abort, +-- Change_Base_Priority + +pragma Elaborate_All (System.Tasking.Initialization); +-- This insures that tasking is initialized if any protected objects are +-- created. + +with System.Tasking.Queuing; +-- used for Enqueue +-- Broadcast_Program_Error +-- Select_Protected_Entry_Call +-- Onqueue +-- Count_Waiting + +with System.Tasking.Rendezvous; +-- used for Task_Do_Or_Queue + +with System.Tasking.Debug; +-- used for Trace + +package body System.Tasking.Protected_Objects.Operations is + + package STPO renames System.Task_Primitives.Operations; + + use Task_Primitives; + use Tasking; + use Ada.Exceptions; + use Entries; + + ----------------------- + -- 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. + + --------------------------------- + -- 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; + -- _init_proc (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 both + -- Cancel_Protected_Entry_Call and 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 + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + 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; + +-- ????? +-- The caller should do the following, after return from this +-- procedure, if Call_In_Progress /= null +-- Write_Lock (Entry_Call.Self); +-- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done); +-- Unlock (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; + With_Abort : Boolean) + is + E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E); + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + 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; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + + else + -- Body of current entry requeued the call + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call was requeued to a task + + if not Rendezvous.Task_Do_Or_Queue + (Self_ID, Entry_Call, + With_Abort => Entry_Call.Requeue_With_Abort) + then + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end if; + return; + end if; + + if Object /= New_Object then + -- Requeue is on a different object + + Lock_Entries (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, With_Abort); + PO_Service_Entries (Self_ID, New_Object); + Unlock_Entries (New_Object); + end if; + + else + -- Requeue is on same protected object + + if Entry_Call.Requeue_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 With_Abort 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); + + else + -- ????? + -- Can we convert this recursion to a loop? + + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort); + end if; + end if; + end if; + + 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); + + else + -- Conditional_Call and With_Abort + + STPO.Write_Lock (Entry_Call.Self); + pragma Assert (Entry_Call.State >= Was_Abortable); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + 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 : Protection_Entries_Access) + is + Entry_Call : Entry_Call_Link; + E : Protected_Entry_Index; + Caller : Task_ID; + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + + begin + loop + Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); + + if Entry_Call /= null then + 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 + 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 + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + else + -- Call needs to be requeued + + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if not Rendezvous.Task_Do_Or_Queue + (Self_ID, Entry_Call, + With_Abort => Entry_Call.Requeue_With_Abort) + then + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + -- Requeue is to different PO + + Lock_Entries (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, + Entry_Call.Requeue_With_Abort); + PO_Service_Entries (Self_ID, New_Object); + Unlock_Entries (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 (False); + + if Entry_Call.Requeue_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; + exit; + end if; + + if not Entry_Call.Requeue_With_Abort 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, + Entry_Call.Requeue_With_Abort); + + else + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, + Entry_Call.Requeue_With_Abort); + end if; + end if; + end if; + end if; + + else + exit; + end if; + end loop; + 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; + -- _init_proc (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 + -- 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 : 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 Self_ID.ATC_Nesting_Level = ATC_Level'Last then + Raise_Exception (Storage_Error'Identity, + "not enough ATC nesting levels"); + end if; + + Initialization.Defer_Abort (Self_ID); + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + + -- Failed ceiling check + + Initialization.Undefer_Abort (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; + + if Self_ID.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + 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; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True); + Initially_Abortable := Entry_Call.State = Now_Abortable; + PO_Service_Entries (Self_ID, Object); + + Unlock_Entries (Object); + + -- Try to prevent waiting later (in 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. + + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Block.Enqueued := False; + Block.Cancelled := Entry_Call.State = Cancelled; + Initialization.Undefer_Abort (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 + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; + + elsif Mode < Asynchronous_Call then + + -- Simple_Call or Conditional_Call + + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call); + STPO.Unlock (Self_ID); + Block.Cancelled := Entry_Call.State = Cancelled; + + else + pragma Assert (False); + null; + end if; + + Initialization.Undefer_Abort (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + + end Protected_Entry_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.Requeue_With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_Entry; + + ------------------------------------- + -- Requeue_Task_To_Protected_Entry -- + ------------------------------------- + + -- Compiler interface only. + + -- 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); + STPO.Write_Lock (Self_ID); + Entry_Call.Needs_Requeue := True; + Entry_Call.Requeue_With_Abort := With_Abort; + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + STPO.Unlock (Self_ID); + Entry_Call.E := Entry_Index (E); + Initialization.Undefer_Abort (Self_ID); + end Requeue_Task_To_Protected_Entry; + + -- ?????? + -- Do we really need to lock Self_ID above? + -- Might the caller be trying to cancel? + -- If so, it should fail, since the call state should not be + -- abortable while the call is in service. + + --------------------- + -- 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 : Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + Ceiling_Violation : Boolean; + + begin + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + Raise_Exception (Storage_Error'Identity, + "not enough ATC nesting levels"); + end if; + + Initialization.Defer_Abort (Self_ID); + Lock_Entries (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; + + if Self_ID.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + 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; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True); + PO_Service_Entries (Self_ID, Object); + + Unlock_Entries (Object); + + -- Try to avoid waiting for completed or cancelled calls. + + if Entry_Call.State >= Done then + 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_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Self_ID, Entry_Call, Timeout, Mode); + Initialization.Undefer_Abort (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 : 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 + 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); + 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; |