File : s-taenca.adb
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S --
-- --
-- B o d y --
-- --
-- $Revision: 1.32 $
-- --
-- Copyright (C) 1991-1999, 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 provides internal RTS calls implementing operations
-- that apply to general entry calls, that is, calls to either
-- protected or task entries.
-- These declarations are not part of the GNARL interface
with System.Task_Primitives.Operations;
-- used for STPO.Write_Lock
-- Unlock
-- STPO.Get_Priority
-- Sleep
-- Timed_Sleep
with System.Tasking.Initialization;
-- used for Change_Base_Priority
-- Poll_Base_Priority_Change_At_Entry_Call
-- Dynamic_Priority_Support
-- Defer_Abort/Undefer_Abort
with System.Tasking.Protected_Objects.Entries;
-- used for To_Protection
with System.Tasking.Protected_Objects.Operations;
-- used for PO_Service_Entries
with System.Tasking.Queuing;
-- used for Requeue_Call_With_New_Prio
-- Onqueue
-- Dequeue_Call
with System.Tasking.Utilities;
-- used for Exit_One_ATC_Level
package body System.Tasking.Entry_Calls is
package STPO renames System.Task_Primitives.Operations;
use System.Task_Primitives;
use System.Tasking.Protected_Objects.Entries;
use System.Tasking.Protected_Objects.Operations;
-- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
-- internally. Those operations will raise Program_Error, which
-- we do are not prepared to handle inside the RTS. Instead, use
-- System.Task_Primitives lock operations directly on Protection.L.
-----------------------
-- Local Subprograms --
-----------------------
procedure Lock_Server (Entry_Call : Entry_Call_Link);
-- This locks the server targeted by Entry_Call.
--
-- This may be a task or a protected object,
-- depending on the target of the original call or any subsequent
-- requeues.
--
-- This routine is needed because the field specifying the server
-- for this call must be protected by the server's mutex. If it were
-- protected by the caller's mutex, accessing the server's queues would
-- require locking the caller to get the server, locking the server,
-- and then accessing the queues. This involves holding two ATCB
-- locks at once, something which we can guarantee that it will always
-- be done in the same order, or locking a protected object while we
-- hold an ATCB lock, something which is not permitted. Since
-- the server cannot be obtained reliably, it must be obtained unreliably
-- and then checked again once it has been locked.
procedure Unlock_Server (Entry_Call : Entry_Call_Link);
-- STPO.Unlock the server targeted by Entry_Call. The server must
-- be locked before calling this.
procedure Unlock_And_Update_Server
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link);
-- Similar to Unlock_Server, but services entry calls if the
-- server is a protected object.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Pending_Actions_For_Entry_Call);
-- This procedure performs priority change of a queued call and
-- dequeuing of an entry call when an the call is cancelled.
-- If the call is dequeued the state should be set to Cancelled.
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link);
pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
-- Has to be called with the Self_ID's ATCB write-locked.
-- May temporariliy release the lock.
-----------------
-- Lock_Server --
-----------------
-- This should only be called by the Entry_Call.Self.
-- It should be holding no other ATCB locks at the time.
procedure Lock_Server (Entry_Call : Entry_Call_Link) is
Test_Task : Task_ID;
Test_PO : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Failures : Integer := 0;
begin
Test_Task := Entry_Call.Called_Task;
loop
if Test_Task = null then
-- Entry_Call was queued on a protected object,
-- or in transition, when we last fetched Test_Task.
Test_PO := To_Protection (Entry_Call.Called_PO);
if Test_PO = null then
-- We had very bad luck, interleaving with TWO different
-- requeue operations. Go around the loop and try again.
STPO.Yield;
else
STPO.Write_Lock (Test_PO.L'Access, Ceiling_Violation);
-- ????
-- The following code allows Lock_Server to be called
-- when cancelling a call, to allow for the possibility
-- that the priority of the caller has been raised
-- beyond that of the protected entry call by
-- Ada.Dynamic_Priorities.STPO.Set_Priority.
-- If the current task has a higher priority than the ceiling
-- of the protected object, temporarily lower it. It will
-- be reset in Unlock.
if Ceiling_Violation then
declare
Current_Task : Task_ID := STPO.Self;
Old_Base_Priority : System.Any_Priority;
begin
STPO.Write_Lock (Current_Task);
Old_Base_Priority := Current_Task.Base_Priority;
Current_Task.New_Base_Priority := Test_PO.Ceiling;
System.Tasking.Initialization.Change_Base_Priority
(Current_Task);
STPO.Unlock (Current_Task);
-- Following lock should not fail
STPO.Write_Lock (Test_PO.L'Access, Ceiling_Violation);
Test_PO.Old_Base_Priority := Old_Base_Priority;
Test_PO.Pending_Action := True;
end;
end if;
exit when To_Address (Test_PO) = Entry_Call.Called_PO;
STPO.Unlock (Test_PO.L'Access);
end if;
else
STPO.Write_Lock (Test_Task);
exit when Test_Task = Entry_Call.Called_Task;
STPO.Unlock (Test_Task);
end if;
Test_Task := Entry_Call.Called_Task;
Failures := Failures + 1;
pragma Assert (Failures <= 5);
end loop;
end Lock_Server;
-------------------
-- Unlock_Server --
-------------------
procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
Caller : Task_ID;
Called_PO : Protection_Entries_Access;
begin
if Entry_Call.Called_Task /= null then
STPO.Unlock (Entry_Call.Called_Task);
else
Called_PO := To_Protection (Entry_Call.Called_PO);
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
end if;
STPO.Unlock (Called_PO.L'Access);
end if;
end Unlock_Server;
------------------------------
-- Unlock_And_Update_Server --
------------------------------
procedure Unlock_And_Update_Server
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
Called_PO : Protection_Entries_Access;
Caller : Task_ID;
begin
if Entry_Call.Called_Task /= null then
STPO.Unlock (Entry_Call.Called_Task);
else
Called_PO := To_Protection (Entry_Call.Called_PO);
PO_Service_Entries (Self_ID, Called_PO);
if Called_PO.Pending_Action then
Called_PO.Pending_Action := False;
Caller := STPO.Self;
STPO.Write_Lock (Caller);
Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
Initialization.Change_Base_Priority (Caller);
STPO.Unlock (Caller);
end if;
STPO.Unlock (Called_PO.L'Access);
end if;
end Unlock_And_Update_Server;
-------------------------
-- Wait_For_Completion--
-------------------------
-- Call this only when holding Self_ID locked
-- If this is a conditional call, it should be cancelled when it
-- becomes abortable. This is checked in the loop below.
-- We do the same thing for Asynchronous_Call. Executing the following
-- loop will clear the Pending_Action field if there is no
-- Pending_Action. We want the call made from Cancel_Task_Entry_Call
-- to check the abortion level so that we make sure that the Cancelled
-- field reflect the status of an Asynchronous_Call properly.
-- This problem came up when the triggered statement and the abortable
-- part depend on entries of the same task. When a cancellation is
-- delivered, Undefer_Abort in the call made from abortable part
-- sets the Pending_Action bit to false. However, the call is actually
-- made to cancel the Asynchronous Call so that we need to check its
-- status here again. Otherwise we may end up waiting for a cancelled
-- call forever.
-- ????? .........
-- Recheck the logic of the above old comment. It may be stale.
procedure Wait_For_Completion
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
begin
pragma Assert (Self_ID = Entry_Call.Self);
Self_ID.State := Entry_Caller_Sleep;
loop
Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call);
exit when Entry_Call.State >= Done;
STPO.Sleep (Self_ID, Entry_Caller_Sleep);
end loop;
Self_ID.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_ID);
end Wait_For_Completion;
--------------------------------------
-- Wait_For_Completion_With_Timeout --
--------------------------------------
-- This routine will lock Self_ID.
-- This procedure waits for the entry call to
-- be served, with a timeout. It tries to cancel the
-- call if the timeout expires before the call is served.
-- If we wake up from the timed sleep operation here,
-- it may be for several possible reasons:
-- 1) The entry call is done being served.
-- 2) There is an abort or priority change to be served.
-- 3) The timeout has expired (Timedout = True)
-- 4) There has been a spurious wakeup.
-- Once the timeout has expired we may need to continue to wait if
-- the call is already being serviced. In that case, we want to go
-- back to sleep, but without any timeout. The variable Timedout is
-- used to control this. If the Timedout flag is set, we do not need
-- to STPO.Sleep with a timeout. We just sleep until we get a wakeup for
-- some status change.
-- The original call may have become abortable after waking up.
-- We want to check Check_Pending_Actions_For_Entry_Call again
-- in any case.
procedure Wait_For_Completion_With_Timeout
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link;
Wakeup_Time : Duration;
Mode : Delay_Modes)
is
Timedout : Boolean := False;
Yielded : Boolean := False;
use type Ada.Exceptions.Exception_Id;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (Self_ID);
pragma Assert (Entry_Call.Self = Self_ID);
pragma Assert (Entry_Call.Mode = Timed_Call);
Self_ID.State := Entry_Caller_Sleep;
-- Looping is necessary in case the task wakes up early from the
-- timed sleep, due to a "spurious wakeup". Spurious wakeups are
-- a weakness of POSIX condition variables. A thread waiting for
-- a condition variable is allowed to wake up at any time, not just
-- when the condition is signaled. See the same loop in the
-- ordinary Wait_For_Completion, above.
loop
Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call);
exit when Entry_Call.State >= Done;
STPO.Timed_Sleep (Self_ID, Wakeup_Time, Mode,
Entry_Caller_Sleep, Timedout, Yielded);
if Timedout then
-- Try to cancel the call (see Try_To_Cancel_Entry_Call for
-- corresponding code in the ATC case).
Entry_Call.Cancellation_Attempted := True;
if Self_ID.Pending_ATC_Level >= Entry_Call.Level then
Self_ID.Pending_ATC_Level := Entry_Call.Level - 1;
end if;
-- The following loop is the same as the loop and exit code
-- from the ordinary Wait_For_Completion. If we get here, we
-- have timed out but we need to keep waiting until the call
-- has actually completed or been cancelled successfully.
loop
Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call);
exit when Entry_Call.State >= Done;
STPO.Sleep (Self_ID, Entry_Caller_Sleep);
end loop;
Self_ID.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_ID);
STPO.Unlock (Self_ID);
if Entry_Call.State = Cancelled then
Initialization.Undefer_Abort_Nestable (Self_ID);
else
-- ????
Initialization.Undefer_Abort_Nestable (Self_ID);
-- Ideally, abort should no longer be deferred at this
-- point, so we should be able to call Check_Exception.
-- The loop below should be considered temporary,
-- to work around the possiblility that abort may be
-- deferred more than one level deep.
if Entry_Call.Exception_To_Raise /=
Ada.Exceptions.Null_Id then
while Self_ID.Deferral_Level > 0 loop
Initialization.Undefer_Abort_Nestable (Self_ID);
end loop;
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end if;
end if;
return;
end if;
end loop;
-- This last part is the same as ordinary Wait_For_Completion,
-- and is only executed if the call completed without timing out.
Self_ID.State := Runnable;
Utilities.Exit_One_ATC_Level (Self_ID);
STPO.Unlock (Self_ID);
Initialization.Undefer_Abort_Nestable (Self_ID);
if not Yielded then
STPO.Yield;
end if;
end Wait_For_Completion_With_Timeout;
--------------------------
-- Wait_Until_Abortable --
--------------------------
-- Wait to start the abortable part of an async. select statement
-- until the trigger entry call becomes abortable.
procedure Wait_Until_Abortable
(Self_ID : Task_ID;
Call : Entry_Call_Link)
is
begin
pragma Assert (Self_ID.ATC_Nesting_Level > 0);
pragma Assert (Call.Mode = Asynchronous_Call);
STPO.Write_Lock (Self_ID);
Self_ID.State := Entry_Caller_Sleep;
loop
Check_Pending_Actions_For_Entry_Call (Self_ID, Call);
exit when Call.State >= Was_Abortable;
STPO.Sleep (Self_ID, Async_Select_Sleep);
end loop;
Self_ID.State := Runnable;
STPO.Unlock (Self_ID);
end Wait_Until_Abortable;
-- It might seem that we should be holding the server's lock when
-- we test Call.State above.
-- In an earlier version, the code above temporarily unlocked the
-- caller and locked the server just for checking Call.State.
-- The unlocking of the caller risked missing a wakeup
-- (an error) and locking the server had no apparent value.
-- We should not need the server's lock, since once Call.State
-- is set to Was_Abortable or beyond, it never goes back below
-- Was_Abortable until this task starts another entry call.
-- ????
-- It seems that other calls to Lock_Server may also risk missing
-- wakeups. We need to check that they do not have this problem.
---------------------------------------------
-- Poll_Base_Priority_Change_At_Entry_Call --
---------------------------------------------
-- A specialized version of Poll_Base_Priority_Change,
-- that does the optional entry queue reordering.
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
begin
if Initialization.Dynamic_Priority_Support
and then Self_ID.Pending_Priority_Change
then
-- Check for ceiling violations ???
Self_ID.Pending_Priority_Change := False;
if Self_ID.Base_Priority = Self_ID.New_Base_Priority then
STPO.Unlock (Self_ID);
STPO.Yield;
STPO.Write_Lock (Self_ID);
else
if Self_ID.Base_Priority < Self_ID.New_Base_Priority then
-- Raising priority
Self_ID.Base_Priority := Self_ID.New_Base_Priority;
STPO.Set_Priority (Self_ID, Self_ID.Base_Priority);
else
-- Lowering priority
Self_ID.Base_Priority := Self_ID.New_Base_Priority;
STPO.Set_Priority (Self_ID, Self_ID.Base_Priority);
STPO.Unlock (Self_ID);
STPO.Yield;
STPO.Write_Lock (Self_ID);
end if;
end if;
-- Requeue the entry call at the new priority.
-- We need to requeue even if the new priority is the same than
-- the previous (see ACVC cxd4006).
STPO.Unlock (Self_ID);
Lock_Server (Entry_Call);
Queuing.Requeue_Call_With_New_Prio
(Entry_Call, STPO.Get_Priority (Self_ID));
Unlock_And_Update_Server (Self_ID, Entry_Call);
STPO.Write_Lock (Self_ID);
end if;
end Poll_Base_Priority_Change_At_Entry_Call;
-----------------------------------------
-- Check_Pending_Actions_For_Entry_Call --
-----------------------------------------
-- Call only with abort deferred and holding lock of Self_ID. This
-- is a bit of common code for all entry calls. The effect is to do
-- any deferred base priority change operation, in case some other
-- task called STPO.Set_Priority while the current task had abort deferred,
-- and to dequeue the call if the call has been aborted.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
begin
pragma Assert (Self_ID = Entry_Call.Self);
Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call);
if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then Entry_Call.State = Now_Abortable
then
STPO.Unlock (Self_ID);
Lock_Server (Entry_Call);
if Queuing.Onqueue (Entry_Call)
and then Entry_Call.State = Now_Abortable
then
Queuing.Dequeue_Call (Entry_Call);
if Entry_Call.Cancellation_Attempted then
Entry_Call.State := Cancelled;
else
Entry_Call.State := Done;
end if;
Unlock_And_Update_Server (Self_ID, Entry_Call);
else
Unlock_Server (Entry_Call);
end if;
STPO.Write_Lock (Self_ID);
end if;
end Check_Pending_Actions_For_Entry_Call;
------------------------------
-- Try_To_Cancel_Entry_Call --
------------------------------
-- This is used to implement the Cancel_Task_Entry_Call and
-- Cancel_Protected_Entry_Call.
-- Try to cancel async. entry call.
-- Effect includes Abort_To_Level and Wait_For_Completion.
-- Cancelled = True iff the cancelation was successful, i.e.,
-- the call was not Done before this call.
-- On return, the call is off-queue and the ATC level is reduced by one.
procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is
Entry_Call : Entry_Call_Link;
Self_ID : constant Task_ID := STPO.Self;
use type Ada.Exceptions.Exception_Id;
begin
Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
-- Experimentation has shown that abort is sometimes (but not
-- always) already deferred when Cancel_X_Entry_Call is called.
-- That may indicate an error. Find out what is going on. ???
pragma Assert (Entry_Call.Mode = Asynchronous_Call);
pragma Assert (Self_ID = Self);
Initialization.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (Self_ID);
Entry_Call.Cancellation_Attempted := True;
if Self_ID.Pending_ATC_Level >= Entry_Call.Level then
Self_ID.Pending_ATC_Level := Entry_Call.Level - 1;
end if;
Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call);
STPO.Unlock (Self_ID);
Succeeded := Entry_Call.State = Cancelled;
if Succeeded then
Initialization.Undefer_Abort_Nestable (Self_ID);
else
-- ????
Initialization.Undefer_Abort_Nestable (Self_ID);
-- Ideally, abort should no longer be deferred at this
-- point, so we should be able to call Check_Exception.
-- The loop below should be considered temporary,
-- to work around the possiblility that abort may be deferred
-- more than one level deep.
if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
while Self_ID.Deferral_Level > 0 loop
System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
end loop;
Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end if;
end if;
end Try_To_Cancel_Entry_Call;
--------------------
-- Reset_Priority --
--------------------
-- Reset the priority of a task completing an accept statement to
-- the value it had before the call.
procedure Reset_Priority
(Acceptor_Prev_Priority : Rendezvous_Priority;
Acceptor : Task_ID) is
begin
if Acceptor_Prev_Priority /= Priority_Not_Boosted then
STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority,
Loss_Of_Inheritance => True);
end if;
end Reset_Priority;
-- ???
-- Check why we don't need any kind of lock to do this.
-- Do we limit this kind of "active" priority change to be done
-- by the task for itself only?
---------------------
-- Check_Exception --
---------------------
-- Raise any pending exception from the Entry_Call.
-- This should be called at the end of every compiler interface
-- procedure that implements an entry call.
-- In principle, the caller should not be abort-deferred (unless
-- the application program violates the Ada language rules by doing
-- entry calls from within protected operations -- an erroneous practice
-- apparently followed with success by some adventurous GNAT users).
-- Absolutely, the caller should not be holding any locks, or there
-- will be deadlock.
procedure Check_Exception
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
is
use type Ada.Exceptions.Exception_Id;
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;
begin
-- pragma Assert (Self_ID.Deferral_Level = 0);
-- The above may be useful for debugging, but the Florist packages
-- contain critical sections that defer abort and then do entry calls,
-- which causes the above Assert to trip.
if E /= Ada.Exceptions.Null_Id then
Internal_Raise (E);
end if;
end Check_Exception;
end System.Tasking.Entry_Calls;