| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| -- -- |
| -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1998-2022, 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.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 Ada.Exceptions; |
| use Entries; |
| |
| use System.Restrictions; |
| use System.Restrictions.Rident; |
| |
| ----------------------- |
| -- 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 |
| Self_Id := STPO.Self; |
| 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; |
| 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); |
| 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 (Index).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 (Index).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; |
| STPO.Write_Lock (Entry_Call.Self); |
| Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); |
| STPO.Unlock (Entry_Call.Self); |
| |
| 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) |
| or else Object.Entry_Queue_Maxes /= null |
| then |
| -- 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; |
| STPO.Write_Lock (Entry_Call.Self); |
| Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); |
| STPO.Unlock (Entry_Call.Self); |
| |
| return; |
| end if; |
| 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 |
| |
| 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); |
| 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 |
| 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; |
| STPO.Write_Lock (Caller); |
| Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); |
| STPO.Unlock (Caller); |
| 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 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 |
| |
| STPO.Write_Lock (Self_ID); |
| Utilities.Exit_One_ATC_Level (Self_ID); |
| STPO.Unlock (Self_ID); |
| |
| 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 |
| Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); |
| end if; |
| |
| else |
| case Mode is |
| when Conditional_Call |
| | Simple_Call |
| => |
| STPO.Write_Lock (Self_ID); |
| Entry_Calls.Wait_For_Completion (Entry_Call); |
| STPO.Unlock (Self_ID); |
| |
| Block.Cancelled := Entry_Call.State = Cancelled; |
| |
| when Asynchronous_Call |
| | Timed_Call |
| => |
| pragma Assert (Standard.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 |
| |
| Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); |
| |
| if not Result 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_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; |
| |
| STPO.Write_Lock (Entry_Call.Self); |
| Initialization.Wakeup_Entry_Caller |
| (Self_Id, Entry_Call, Done); |
| STPO.Unlock (Entry_Call.Self); |
| |
| 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; |
| |
| 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; |
| |
| 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); |
| STPO.Write_Lock (Self_Id); |
| |
| -- Try to avoid waiting for completed or cancelled calls |
| |
| if Entry_Call.State >= Done then |
| Utilities.Exit_One_ATC_Level (Self_Id); |
| STPO.Unlock (Self_Id); |
| |
| 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); |
| STPO.Unlock (Self_Id); |
| |
| -- ??? 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 |
| 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; |
