URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasren.adb] - Blame information for rev 729

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
--                                                                          --
--            S Y S T E M . T A S K I N G . R E N D E Z V O U S             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 1992-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.     --
--                                                                          --
------------------------------------------------------------------------------
 
with System.Task_Primitives.Operations;
with System.Tasking.Entry_Calls;
with System.Tasking.Initialization;
with System.Tasking.Queuing;
with System.Tasking.Utilities;
with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
with System.Restrictions;
with System.Parameters;
with System.Traces.Tasking;
 
package body System.Tasking.Rendezvous is
 
   package STPO renames System.Task_Primitives.Operations;
   package POO renames Protected_Objects.Operations;
   package POE renames Protected_Objects.Entries;
 
   use Parameters;
   use Task_Primitives.Operations;
   use System.Traces;
   use System.Traces.Tasking;
 
   type Select_Treatment is (
     Accept_Alternative_Selected,   --  alternative with non-null body
     Accept_Alternative_Completed,  --  alternative with null body
     Else_Selected,
     Terminate_Selected,
     Accept_Alternative_Open,
     No_Alternative_Open);
 
   ----------------
   -- Local Data --
   ----------------
 
   Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
     (Simple_Mode         => No_Alternative_Open,
      Else_Mode           => Else_Selected,
      Terminate_Mode      => Terminate_Selected,
      Delay_Mode          => No_Alternative_Open);
 
   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)
       );
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   procedure Local_Defer_Abort (Self_Id : Task_Id) renames
     System.Tasking.Initialization.Defer_Abort_Nestable;
 
   procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
     System.Tasking.Initialization.Undefer_Abort_Nestable;
 
   --  Florist defers abort around critical sections that make entry calls
   --  to the Interrupt_Manager task, which violates the general rule about
   --  top-level runtime system calls from abort-deferred regions. It is not
   --  that this is unsafe, but when it occurs in "normal" programs it usually
   --  means either the user is trying to do a potentially blocking operation
   --  from within a protected object, or there is a runtime system/compiler
   --  error that has failed to undefer an earlier abort deferral. Thus, for
   --  debugging it may be wise to modify the above renamings to the
   --  non-nestable forms.
 
   procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
   --  Internal version of Complete_Rendezvous, used to implement
   --  Complete_Rendezvous and Exceptional_Complete_Rendezvous.
   --  Should be called holding no locks, generally with abort
   --  not yet deferred.
 
   procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
   pragma Inline (Boost_Priority);
   --  Call this only with abort deferred and holding lock of Acceptor
 
   procedure Call_Synchronous
     (Acceptor              : Task_Id;
      E                     : Task_Entry_Index;
      Uninterpreted_Data    : System.Address;
      Mode                  : Call_Modes;
      Rendezvous_Successful : out Boolean);
   pragma Inline (Call_Synchronous);
   --  This call is used to make a simple or conditional entry call.
   --  Called from Call_Simple and Task_Entry_Call.
 
   procedure Setup_For_Rendezvous_With_Body
     (Entry_Call : Entry_Call_Link;
      Acceptor   : Task_Id);
   pragma Inline (Setup_For_Rendezvous_With_Body);
   --  Call this only with abort deferred and holding lock of Acceptor. When
   --  a rendezvous selected (ready for rendezvous) we need to save previous
   --  caller and adjust the priority. Also we need to make this call not
   --  Abortable (Cancellable) since the rendezvous has already been started.
 
   procedure Wait_For_Call (Self_Id : Task_Id);
   pragma Inline (Wait_For_Call);
   --  Call this only with abort deferred and holding lock of Self_Id. An
   --  accepting task goes into Sleep by calling this routine waiting for a
   --  call from the caller or waiting for an abort. Make sure Self_Id is
   --  locked before calling this routine.
 
   -----------------
   -- Accept_Call --
   -----------------
 
   procedure Accept_Call
     (E                  : Task_Entry_Index;
      Uninterpreted_Data : out System.Address)
   is
      Self_Id      : constant Task_Id := STPO.Self;
      Caller       : Task_Id          := null;
      Open_Accepts : aliased Accept_List (1 .. 1);
      Entry_Call   : Entry_Call_Link;
 
   begin
      Initialization.Defer_Abort (Self_Id);
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (Self_Id);
 
      if not Self_Id.Callable then
         pragma Assert (Self_Id.Pending_ATC_Level = 0);
 
         pragma Assert (Self_Id.Pending_Action);
 
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         Initialization.Undefer_Abort (Self_Id);
 
         --  Should never get here ???
 
         pragma Assert (False);
         raise Standard'Abort_Signal;
      end if;
 
      Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
 
      if Entry_Call /= null then
         Caller := Entry_Call.Self;
         Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
         Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
 
      else
         --  Wait for a caller
 
         Open_Accepts (1).Null_Body := False;
         Open_Accepts (1).S := E;
         Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
 
         --  Wait for normal call
 
         if Parameters.Runtime_Traces then
            Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
         end if;
 
         pragma Debug
           (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
         Wait_For_Call (Self_Id);
 
         pragma Assert (Self_Id.Open_Accepts = null);
 
         if Self_Id.Common.Call /= null then
            Caller := Self_Id.Common.Call.Self;
            Uninterpreted_Data :=
              Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
         else
            --  Case of an aborted task
 
            Uninterpreted_Data := System.Null_Address;
         end if;
      end if;
 
      --  Self_Id.Common.Call should already be updated by the Caller. On
      --  return, we will start the rendezvous.
 
      STPO.Unlock (Self_Id);
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      Initialization.Undefer_Abort (Self_Id);
 
      if Parameters.Runtime_Traces then
         Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
      end if;
   end Accept_Call;
 
   --------------------
   -- Accept_Trivial --
   --------------------
 
   procedure Accept_Trivial (E : Task_Entry_Index) is
      Self_Id      : constant Task_Id := STPO.Self;
      Caller       : Task_Id          := null;
      Open_Accepts : aliased Accept_List (1 .. 1);
      Entry_Call   : Entry_Call_Link;
 
   begin
      Initialization.Defer_Abort_Nestable (Self_Id);
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (Self_Id);
 
      if not Self_Id.Callable then
         pragma Assert (Self_Id.Pending_ATC_Level = 0);
 
         pragma Assert (Self_Id.Pending_Action);
 
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         Initialization.Undefer_Abort_Nestable (Self_Id);
 
         --  Should never get here ???
 
         pragma Assert (False);
         raise Standard'Abort_Signal;
      end if;
 
      Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
 
      if Entry_Call = null then
 
         --  Need to wait for entry call
 
         Open_Accepts (1).Null_Body := True;
         Open_Accepts (1).S := E;
         Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
 
         if Parameters.Runtime_Traces then
            Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
         end if;
 
         pragma Debug
          (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
 
         Wait_For_Call (Self_Id);
 
         pragma Assert (Self_Id.Open_Accepts = null);
 
         --  No need to do anything special here for pending abort.
         --  Abort_Signal will be raised by Undefer on exit.
 
         STPO.Unlock (Self_Id);
 
      --  Found caller already waiting
 
      else
         pragma Assert (Entry_Call.State < Done);
 
         STPO.Unlock (Self_Id);
         Caller := Entry_Call.Self;
 
         STPO.Write_Lock (Caller);
         Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
         STPO.Unlock (Caller);
      end if;
 
      if Parameters.Runtime_Traces then
         Send_Trace_Info (M_Accept_Complete);
 
         --  Fake one, since there is (???) no way to know that the rendezvous
         --  is over.
 
         Send_Trace_Info (M_RDV_Complete);
      end if;
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      Initialization.Undefer_Abort_Nestable (Self_Id);
   end Accept_Trivial;
 
   --------------------
   -- Boost_Priority --
   --------------------
 
   procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
      Caller        : constant Task_Id             := Call.Self;
      Caller_Prio   : constant System.Any_Priority := Get_Priority (Caller);
      Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
   begin
      if Caller_Prio > Acceptor_Prio then
         Call.Acceptor_Prev_Priority := Acceptor_Prio;
         Set_Priority (Acceptor, Caller_Prio);
      else
         Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
      end if;
   end Boost_Priority;
 
   -----------------
   -- Call_Simple --
   -----------------
 
   procedure Call_Simple
     (Acceptor           : Task_Id;
      E                  : Task_Entry_Index;
      Uninterpreted_Data : System.Address)
   is
      Rendezvous_Successful : Boolean;
      pragma Unreferenced (Rendezvous_Successful);
 
   begin
      --  If pragma Detect_Blocking is active then Program_Error must be
      --  raised if this potentially blocking operation is called from a
      --  protected action.
 
      if System.Tasking.Detect_Blocking
        and then STPO.Self.Common.Protected_Action_Nesting > 0
      then
         raise Program_Error with "potentially blocking operation";
      end if;
 
      Call_Synchronous
        (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
   end Call_Simple;
 
   ----------------------
   -- Call_Synchronous --
   ----------------------
 
   procedure Call_Synchronous
     (Acceptor              : Task_Id;
      E                     : Task_Entry_Index;
      Uninterpreted_Data    : System.Address;
      Mode                  : Call_Modes;
      Rendezvous_Successful : out Boolean)
   is
      Self_Id    : constant Task_Id := STPO.Self;
      Level      : ATC_Level;
      Entry_Call : Entry_Call_Link;
 
   begin
      pragma Assert (Mode /= Asynchronous_Call);
 
      Local_Defer_Abort (Self_Id);
      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
      pragma Debug
        (Debug.Trace (Self_Id, "CS: entered ATC level: " &
         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
      Level := Self_Id.ATC_Nesting_Level;
      Entry_Call := Self_Id.Entry_Calls (Level)'Access;
      Entry_Call.Next := null;
      Entry_Call.Mode := Mode;
      Entry_Call.Cancellation_Attempted := False;
 
      if Parameters.Runtime_Traces then
         Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
      end if;
 
      --  If this is a call made inside of an abort deferred region,
      --  the call should be never abortable.
 
      Entry_Call.State :=
        (if Self_Id.Deferral_Level > 1
         then Never_Abortable
         else Now_Abortable);
 
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Prio := Get_Priority (Self_Id);
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
      Entry_Call.Called_Task := Acceptor;
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
      Entry_Call.With_Abort := True;
 
      --  Note: the caller will undefer abort on return (see WARNING above)
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
         STPO.Write_Lock (Self_Id);
         Utilities.Exit_One_ATC_Level (Self_Id);
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         if Parameters.Runtime_Traces then
            Send_Trace_Info (E_Missed, Acceptor);
         end if;
 
         Local_Undefer_Abort (Self_Id);
         raise Tasking_Error;
      end if;
 
      STPO.Write_Lock (Self_Id);
      pragma Debug
        (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
      Entry_Calls.Wait_For_Completion (Entry_Call);
      pragma Debug
        (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
      Rendezvous_Successful := Entry_Call.State = Done;
      STPO.Unlock (Self_Id);
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      Local_Undefer_Abort (Self_Id);
      Entry_Calls.Check_Exception (Self_Id, Entry_Call);
   end Call_Synchronous;
 
   --------------
   -- Callable --
   --------------
 
   function Callable (T : Task_Id) return Boolean is
      Result  : Boolean;
      Self_Id : constant Task_Id := STPO.Self;
 
   begin
      Initialization.Defer_Abort_Nestable (Self_Id);
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (T);
      Result := T.Callable;
      STPO.Unlock (T);
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      Initialization.Undefer_Abort_Nestable (Self_Id);
      return Result;
   end Callable;
 
   ----------------------------
   -- Cancel_Task_Entry_Call --
   ----------------------------
 
   procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
   begin
      Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
   end Cancel_Task_Entry_Call;
 
   -------------------------
   -- Complete_Rendezvous --
   -------------------------
 
   procedure Complete_Rendezvous is
   begin
      Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
   end Complete_Rendezvous;
 
   -------------------------------------
   -- Exceptional_Complete_Rendezvous --
   -------------------------------------
 
   procedure Exceptional_Complete_Rendezvous
     (Ex : Ada.Exceptions.Exception_Id)
   is
      procedure Internal_Reraise;
      pragma No_Return (Internal_Reraise);
      pragma Import (C, Internal_Reraise, "__gnat_reraise");
 
   begin
      Local_Complete_Rendezvous (Ex);
      Internal_Reraise;
 
      --  ??? Do we need to give precedence to Program_Error that might be
      --  raised due to failure of finalization, over Tasking_Error from
      --  failure of requeue?
   end Exceptional_Complete_Rendezvous;
 
   -------------------------------
   -- Local_Complete_Rendezvous --
   -------------------------------
 
   procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
      Self_Id                : constant Task_Id := STPO.Self;
      Entry_Call             : Entry_Call_Link := Self_Id.Common.Call;
      Caller                 : Task_Id;
      Called_PO              : STPE.Protection_Entries_Access;
      Acceptor_Prev_Priority : Integer;
 
      Ceiling_Violation : Boolean;
 
      use type Ada.Exceptions.Exception_Id;
      procedure Transfer_Occurrence
        (Target : Ada.Exceptions.Exception_Occurrence_Access;
         Source : Ada.Exceptions.Exception_Occurrence);
      pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 
      use type STPE.Protection_Entries_Access;
 
   begin
      --  The deferral level is critical here, since we want to raise an
      --  exception or allow abort to take place, if there is an exception or
      --  abort pending.
 
      pragma Debug
        (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
 
      if Ex = Ada.Exceptions.Null_Id then
 
         --  The call came from normal end-of-rendezvous, so abort is not yet
         --  deferred.
 
         if Parameters.Runtime_Traces then
            Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
         end if;
 
         Initialization.Defer_Abort_Nestable (Self_Id);
 
      elsif ZCX_By_Default then
 
         --  With ZCX, aborts are not automatically deferred in handlers
 
         Initialization.Defer_Abort_Nestable (Self_Id);
      end if;
 
      --  We need to clean up any accepts which Self may have been serving when
      --  it was aborted.
 
      if Ex = Standard'Abort_Signal'Identity then
         if Single_Lock then
            Lock_RTS;
         end if;
 
         while Entry_Call /= null loop
            Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
 
            --  All forms of accept make sure that the acceptor is not
            --  completed, before accepting further calls, so that we
            --  can be sure that no further calls are made after the
            --  current calls are purged.
 
            Caller := Entry_Call.Self;
 
            --  Take write lock. This follows the lock precedence rule that
            --  Caller may be locked while holding lock of Acceptor. Complete
            --  the call abnormally, with exception.
 
            STPO.Write_Lock (Caller);
            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
            STPO.Unlock (Caller);
            Entry_Call := Entry_Call.Acceptor_Prev_Call;
         end loop;
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
      else
         Caller := Entry_Call.Self;
 
         if Entry_Call.Needs_Requeue then
 
            --  We dare not lock Self_Id at the same time as Caller, for fear
            --  of deadlock.
 
            Entry_Call.Needs_Requeue := False;
            Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
 
            if Entry_Call.Called_Task /= null then
 
               --  Requeue to another task entry
 
               if Single_Lock then
                  Lock_RTS;
               end if;
 
               if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
                  if Single_Lock then
                     Unlock_RTS;
                  end if;
 
                  Initialization.Undefer_Abort (Self_Id);
                  raise Tasking_Error;
               end if;
 
               if Single_Lock then
                  Unlock_RTS;
               end if;
 
            else
               --  Requeue to a protected entry
 
               Called_PO := POE.To_Protection (Entry_Call.Called_PO);
               STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
 
               if Ceiling_Violation then
                  pragma Assert (Ex = Ada.Exceptions.Null_Id);
                  Entry_Call.Exception_To_Raise := Program_Error'Identity;
 
                  if Single_Lock then
                     Lock_RTS;
                  end if;
 
                  STPO.Write_Lock (Caller);
                  Initialization.Wakeup_Entry_Caller
                    (Self_Id, Entry_Call, Done);
                  STPO.Unlock (Caller);
 
                  if Single_Lock then
                     Unlock_RTS;
                  end if;
 
               else
                  POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
                  POO.PO_Service_Entries (Self_Id, Called_PO);
               end if;
            end if;
 
            Entry_Calls.Reset_Priority
              (Self_Id, Entry_Call.Acceptor_Prev_Priority);
 
         else
            --  The call does not need to be requeued
 
            Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
            Entry_Call.Exception_To_Raise := Ex;
 
            if Single_Lock then
               Lock_RTS;
            end if;
 
            STPO.Write_Lock (Caller);
 
            --  Done with Caller locked to make sure that Wakeup is not lost
 
            if Ex /= Ada.Exceptions.Null_Id then
               Transfer_Occurrence
                 (Caller.Common.Compiler_Data.Current_Excep'Access,
                  Self_Id.Common.Compiler_Data.Current_Excep);
            end if;
 
            Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 
            STPO.Unlock (Caller);
 
            if Single_Lock then
               Unlock_RTS;
            end if;
 
            Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
         end if;
      end if;
 
      Initialization.Undefer_Abort (Self_Id);
   end Local_Complete_Rendezvous;
 
   -------------------------------------
   -- Requeue_Protected_To_Task_Entry --
   -------------------------------------
 
   procedure Requeue_Protected_To_Task_Entry
     (Object     : STPE.Protection_Entries_Access;
      Acceptor   : Task_Id;
      E          : Task_Entry_Index;
      With_Abort : Boolean)
   is
      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
   begin
      pragma Assert (STPO.Self.Deferral_Level > 0);
 
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Called_Task := Acceptor;
      Entry_Call.Called_PO := Null_Address;
      Entry_Call.With_Abort := With_Abort;
      Object.Call_In_Progress := null;
   end Requeue_Protected_To_Task_Entry;
 
   ------------------------
   -- Requeue_Task_Entry --
   ------------------------
 
   procedure Requeue_Task_Entry
     (Acceptor   : Task_Id;
      E          : Task_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);
      Entry_Call.Needs_Requeue := True;
      Entry_Call.With_Abort := With_Abort;
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Called_Task := Acceptor;
      Initialization.Undefer_Abort (Self_Id);
   end Requeue_Task_Entry;
 
   --------------------
   -- Selective_Wait --
   --------------------
 
   procedure Selective_Wait
     (Open_Accepts       : Accept_List_Access;
      Select_Mode        : Select_Modes;
      Uninterpreted_Data : out System.Address;
      Index              : out Select_Index)
   is
      Self_Id          : constant Task_Id := STPO.Self;
      Entry_Call       : Entry_Call_Link;
      Treatment        : Select_Treatment;
      Caller           : Task_Id;
      Selection        : Select_Index;
      Open_Alternative : Boolean;
 
   begin
      Initialization.Defer_Abort (Self_Id);
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (Self_Id);
 
      if not Self_Id.Callable then
         pragma Assert (Self_Id.Pending_ATC_Level = 0);
 
         pragma Assert (Self_Id.Pending_Action);
 
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         --  ??? In some cases abort is deferred more than once. Need to
         --  figure out why this happens.
 
         if Self_Id.Deferral_Level > 1 then
            Self_Id.Deferral_Level := 1;
         end if;
 
         Initialization.Undefer_Abort (Self_Id);
 
         --  Should never get here ???
 
         pragma Assert (False);
         raise Standard'Abort_Signal;
      end if;
 
      pragma Assert (Open_Accepts /= null);
 
      Uninterpreted_Data := Null_Address;
 
      Queuing.Select_Task_Entry_Call
        (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
 
      --  Determine the kind and disposition of the select
 
      Treatment := Default_Treatment (Select_Mode);
      Self_Id.Chosen_Index := No_Rendezvous;
 
      if Open_Alternative then
         if Entry_Call /= null then
            if Open_Accepts (Selection).Null_Body then
               Treatment := Accept_Alternative_Completed;
            else
               Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
               Treatment := Accept_Alternative_Selected;
            end if;
 
            Self_Id.Chosen_Index := Selection;
 
         elsif Treatment = No_Alternative_Open then
            Treatment := Accept_Alternative_Open;
         end if;
      end if;
 
      --  Handle the select according to the disposition selected above
 
      case Treatment is
         when Accept_Alternative_Selected =>
 
            --  Ready to rendezvous
 
            Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 
            --  In this case the accept body is not Null_Body. Defer abort
            --  until it gets into the accept body.
 
            pragma Assert (Self_Id.Deferral_Level = 1);
 
            Initialization.Defer_Abort_Nestable (Self_Id);
            STPO.Unlock (Self_Id);
 
         when Accept_Alternative_Completed =>
 
            --  Accept body is null, so rendezvous is over immediately
 
            if Parameters.Runtime_Traces then
               Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
            end if;
 
            STPO.Unlock (Self_Id);
            Caller := Entry_Call.Self;
 
            STPO.Write_Lock (Caller);
            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
            STPO.Unlock (Caller);
 
         when Accept_Alternative_Open =>
 
            --  Wait for caller
 
            Self_Id.Open_Accepts := Open_Accepts;
            pragma Debug
              (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
 
            if Parameters.Runtime_Traces then
               Send_Trace_Info (W_Select, Self_Id,
                                Integer (Open_Accepts'Length));
            end if;
 
            Wait_For_Call (Self_Id);
 
            pragma Assert (Self_Id.Open_Accepts = null);
 
            --  Self_Id.Common.Call should already be updated by the Caller if
            --  not aborted. It might also be ready to do rendezvous even if
            --  this wakes up due to an abort. Therefore, if the call is not
            --  empty we need to do the rendezvous if the accept body is not
            --  Null_Body.
 
            --  Aren't the first two conditions below redundant???
 
            if Self_Id.Chosen_Index /= No_Rendezvous
              and then Self_Id.Common.Call /= null
              and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
            then
               Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 
               pragma Assert
                 (Self_Id.Deferral_Level = 1
                   or else
                     (Self_Id.Deferral_Level = 0
                       and then not Restrictions.Abort_Allowed));
 
               Initialization.Defer_Abort_Nestable (Self_Id);
 
               --  Leave abort deferred until the accept body
            end if;
 
            STPO.Unlock (Self_Id);
 
         when Else_Selected =>
            pragma Assert (Self_Id.Open_Accepts = null);
 
            if Parameters.Runtime_Traces then
               Send_Trace_Info (M_Select_Else);
            end if;
 
            STPO.Unlock (Self_Id);
 
         when Terminate_Selected =>
 
            --  Terminate alternative is open
 
            Self_Id.Open_Accepts := Open_Accepts;
            Self_Id.Common.State := Acceptor_Sleep;
 
            --  Notify ancestors that this task is on a terminate alternative
 
            STPO.Unlock (Self_Id);
            Utilities.Make_Passive (Self_Id, Task_Completed => False);
            STPO.Write_Lock (Self_Id);
 
            --  Wait for normal entry call or termination
 
            Wait_For_Call (Self_Id);
 
            pragma Assert (Self_Id.Open_Accepts = null);
 
            if Self_Id.Terminate_Alternative then
 
               --  An entry call should have reset this to False, so we must be
               --  aborted. We cannot be in an async. select, since that is not
               --  legal, so the abort must be of the entire task. Therefore,
               --  we do not need to cancel the terminate alternative. The
               --  cleanup will be done in Complete_Master.
 
               pragma Assert (Self_Id.Pending_ATC_Level = 0);
               pragma Assert (Self_Id.Awake_Count = 0);
 
               STPO.Unlock (Self_Id);
 
               if Single_Lock then
                  Unlock_RTS;
               end if;
 
               Index := Self_Id.Chosen_Index;
               Initialization.Undefer_Abort_Nestable (Self_Id);
 
               if Self_Id.Pending_Action then
                  Initialization.Do_Pending_Action (Self_Id);
               end if;
 
               return;
 
            else
               --  Self_Id.Common.Call and Self_Id.Chosen_Index
               --  should already be updated by the Caller.
 
               if Self_Id.Chosen_Index /= No_Rendezvous
                 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
               then
                  Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 
                  pragma Assert (Self_Id.Deferral_Level = 1);
 
                  --  We need an extra defer here, to keep abort
                  --  deferred until we get into the accept body
 
                  Initialization.Defer_Abort_Nestable (Self_Id);
               end if;
            end if;
 
            STPO.Unlock (Self_Id);
 
         when No_Alternative_Open =>
 
            --  In this case, Index will be No_Rendezvous on return, which
            --  should cause a Program_Error if it is not a Delay_Mode.
 
            --  If delay alternative exists (Delay_Mode) we should suspend
            --  until the delay expires.
 
            Self_Id.Open_Accepts := null;
 
            if Select_Mode = Delay_Mode then
               Self_Id.Common.State := Delay_Sleep;
 
               loop
                  exit when
                    Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
                  Sleep (Self_Id, Delay_Sleep);
               end loop;
 
               Self_Id.Common.State := Runnable;
               STPO.Unlock (Self_Id);
 
            else
               STPO.Unlock (Self_Id);
 
               if Single_Lock then
                  Unlock_RTS;
               end if;
 
               Initialization.Undefer_Abort (Self_Id);
               raise Program_Error with "Entry call not a delay mode";
            end if;
      end case;
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      --  Caller has been chosen
 
      --  Self_Id.Common.Call should already be updated by the Caller.
 
      --  Self_Id.Chosen_Index should either be updated by the Caller
      --  or by Test_Selective_Wait.
 
      --  On return, we sill start rendezvous unless the accept body is
      --  null. In the latter case, we will have already completed the RV.
 
      Index := Self_Id.Chosen_Index;
      Initialization.Undefer_Abort_Nestable (Self_Id);
   end Selective_Wait;
 
   ------------------------------------
   -- Setup_For_Rendezvous_With_Body --
   ------------------------------------
 
   procedure Setup_For_Rendezvous_With_Body
     (Entry_Call : Entry_Call_Link;
      Acceptor   : Task_Id) is
   begin
      Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
      Acceptor.Common.Call := Entry_Call;
 
      if Entry_Call.State = Now_Abortable then
         Entry_Call.State := Was_Abortable;
      end if;
 
      Boost_Priority (Entry_Call, Acceptor);
   end Setup_For_Rendezvous_With_Body;
 
   ----------------
   -- Task_Count --
   ----------------
 
   function Task_Count (E : Task_Entry_Index) return Natural is
      Self_Id      : constant Task_Id := STPO.Self;
      Return_Count : Natural;
 
   begin
      Initialization.Defer_Abort (Self_Id);
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (Self_Id);
      Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
      STPO.Unlock (Self_Id);
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      Initialization.Undefer_Abort (Self_Id);
 
      return Return_Count;
   end Task_Count;
 
   ----------------------
   -- Task_Do_Or_Queue --
   ----------------------
 
   function Task_Do_Or_Queue
     (Self_ID    : Task_Id;
      Entry_Call : Entry_Call_Link) return Boolean
   is
      E             : constant Task_Entry_Index :=
                        Task_Entry_Index (Entry_Call.E);
      Old_State     : constant Entry_Call_State := Entry_Call.State;
      Acceptor      : constant Task_Id := Entry_Call.Called_Task;
      Parent        : constant Task_Id := Acceptor.Common.Parent;
      Null_Body     : Boolean;
 
   begin
      --  Find out whether Entry_Call can be accepted immediately
 
      --    If the Acceptor is not callable, return False.
      --    If the rendezvous can start, initiate it.
      --    If the accept-body is trivial, also complete the rendezvous.
      --    If the acceptor is not ready, enqueue the call.
 
      --  This should have a special case for Accept_Call and Accept_Trivial,
      --  so that we don't have the loop setup overhead, below.
 
      --  The call state Done is used here and elsewhere to include both the
      --  case of normal successful completion, and the case of an exception
      --  being raised. The difference is that if an exception is raised no one
      --  will pay attention to the fact that State = Done. Instead the
      --  exception will be raised in Undefer_Abort, and control will skip past
      --  the place where we normally would resume from an entry call.
 
      pragma Assert (not Queuing.Onqueue (Entry_Call));
 
      --  We rely that the call is off-queue for protection, that the caller
      --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
      --  record for another call. We rely on the Caller's lock for call State
      --  mod's.
 
      --  If Acceptor.Terminate_Alternative is True, we need to lock Parent and
      --  Acceptor, in that order; otherwise, we only need a lock on Acceptor.
      --  However, we can't check Acceptor.Terminate_Alternative until Acceptor
      --  is locked. Therefore, we need to lock both. Attempts to avoid locking
      --  Parent tend to result in race conditions. It would work to unlock
      --  Parent immediately upon finding Acceptor.Terminate_Alternative to be
      --  False, but that violates the rule of properly nested locking (see
      --  System.Tasking).
 
      STPO.Write_Lock (Parent);
      STPO.Write_Lock (Acceptor);
 
      --  If the acceptor is not callable, abort the call and return False
 
      if not Acceptor.Callable then
         STPO.Unlock (Acceptor);
         STPO.Unlock (Parent);
 
         pragma Assert (Entry_Call.State < Done);
 
         --  In case we are not the caller, set up the caller
         --  to raise Tasking_Error when it wakes up.
 
         STPO.Write_Lock (Entry_Call.Self);
         Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
         Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
         STPO.Unlock (Entry_Call.Self);
 
         return False;
      end if;
 
      --  Try to serve the call immediately
 
      if Acceptor.Open_Accepts /= null then
         for J in Acceptor.Open_Accepts'Range loop
            if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
 
               --  Commit acceptor to rendezvous with us
 
               Acceptor.Chosen_Index := J;
               Null_Body := Acceptor.Open_Accepts (J).Null_Body;
               Acceptor.Open_Accepts := null;
 
               --  Prevent abort while call is being served
 
               if Entry_Call.State = Now_Abortable then
                  Entry_Call.State := Was_Abortable;
               end if;
 
               if Acceptor.Terminate_Alternative then
 
                  --  Cancel terminate alternative. See matching code in
                  --  Selective_Wait and Vulnerable_Complete_Master.
 
                  Acceptor.Terminate_Alternative := False;
                  Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
 
                  if Acceptor.Awake_Count = 1 then
 
                     --  Notify parent that acceptor is awake
 
                     pragma Assert (Parent.Awake_Count > 0);
 
                     Parent.Awake_Count := Parent.Awake_Count + 1;
 
                     if Parent.Common.State = Master_Completion_Sleep
                       and then Acceptor.Master_of_Task = Parent.Master_Within
                     then
                        Parent.Common.Wait_Count :=
                          Parent.Common.Wait_Count + 1;
                     end if;
                  end if;
               end if;
 
               if Null_Body then
 
                  --  Rendezvous is over immediately
 
                  STPO.Wakeup (Acceptor, Acceptor_Sleep);
                  STPO.Unlock (Acceptor);
                  STPO.Unlock (Parent);
 
                  STPO.Write_Lock (Entry_Call.Self);
                  Initialization.Wakeup_Entry_Caller
                    (Self_ID, Entry_Call, Done);
                  STPO.Unlock (Entry_Call.Self);
 
               else
                  Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
 
                  --  For terminate_alternative, acceptor may not be asleep
                  --  yet, so we skip the wakeup
 
                  if Acceptor.Common.State /= Runnable then
                     STPO.Wakeup (Acceptor, Acceptor_Sleep);
                  end if;
 
                  STPO.Unlock (Acceptor);
                  STPO.Unlock (Parent);
               end if;
 
               return True;
            end if;
         end loop;
 
         --  The acceptor is accepting, but not this entry
      end if;
 
      --  If the acceptor was ready to accept this call,
      --  we would not have gotten this far, so now we should
      --  (re)enqueue the call, if the mode permits that.
 
      --  If the call is timed, it may have timed out before the requeue,
      --  in the unusual case where the current accept has taken longer than
      --  the given delay. In that case the requeue is cancelled, and the
      --  outer timed call will be aborted.
 
      if Entry_Call.Mode = Conditional_Call
        or else
          (Entry_Call.Mode = Timed_Call
            and then Entry_Call.With_Abort
            and then Entry_Call.Cancellation_Attempted)
      then
         STPO.Unlock (Acceptor);
         STPO.Unlock (Parent);
 
         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);
 
      else
         --  Timed_Call, Simple_Call, or Asynchronous_Call
 
         Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
 
         --  Update abortability of call
 
         pragma Assert (Old_State < Done);
 
         Entry_Call.State :=
           New_State (Entry_Call.With_Abort, Entry_Call.State);
 
         STPO.Unlock (Acceptor);
         STPO.Unlock (Parent);
 
         if Old_State /= Entry_Call.State
           and then Entry_Call.State = Now_Abortable
           and then Entry_Call.Mode /= Simple_Call
           and then Entry_Call.Self /= Self_ID
 
         --  Asynchronous_Call or Conditional_Call
 
         then
            --  Because of ATCB lock ordering rule
 
            STPO.Write_Lock (Entry_Call.Self);
 
            if Entry_Call.Self.Common.State = Async_Select_Sleep then
 
               --  Caller may not yet have reached wait-point
 
               STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
            end if;
 
            STPO.Unlock (Entry_Call.Self);
         end if;
      end if;
 
      return True;
   end Task_Do_Or_Queue;
 
   ---------------------
   -- Task_Entry_Call --
   ---------------------
 
   procedure Task_Entry_Call
     (Acceptor              : Task_Id;
      E                     : Task_Entry_Index;
      Uninterpreted_Data    : System.Address;
      Mode                  : Call_Modes;
      Rendezvous_Successful : out Boolean)
   is
      Self_Id    : constant Task_Id := STPO.Self;
      Entry_Call : Entry_Call_Link;
 
   begin
      --  If pragma Detect_Blocking is active then Program_Error must be
      --  raised if this potentially blocking operation is called from a
      --  protected action.
 
      if System.Tasking.Detect_Blocking
        and then Self_Id.Common.Protected_Action_Nesting > 0
      then
         raise Program_Error with "potentially blocking operation";
      end if;
 
      if Parameters.Runtime_Traces then
         Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
      end if;
 
      if Mode = Simple_Call or else Mode = Conditional_Call then
         Call_Synchronous
           (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
 
      else
         --  This is an asynchronous call
 
         --  Abort must already be deferred by the compiler-generated code.
         --  Without this, an abort that occurs between the time that this
         --  call is made and the time that the abortable part's cleanup
         --  handler is set up might miss the cleanup handler and leave the
         --  call pending.
 
         Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
         pragma Debug
           (Debug.Trace (Self_Id, "TEC: 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 := Not_Yet_Abortable;
         Entry_Call.E := Entry_Index (E);
         Entry_Call.Prio := Get_Priority (Self_Id);
         Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
         Entry_Call.Called_Task := Acceptor;
         Entry_Call.Called_PO := Null_Address;
         Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
         Entry_Call.With_Abort := True;
 
         if Single_Lock then
            Lock_RTS;
         end if;
 
         if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
            STPO.Write_Lock (Self_Id);
            Utilities.Exit_One_ATC_Level (Self_Id);
            STPO.Unlock (Self_Id);
 
            if Single_Lock then
               Unlock_RTS;
            end if;
 
            Initialization.Undefer_Abort (Self_Id);
 
            if Parameters.Runtime_Traces then
               Send_Trace_Info (E_Missed, Acceptor);
            end if;
 
            raise Tasking_Error;
         end if;
 
         --  The following is special for async. entry calls. If the call was
         --  not queued abortably, we need to wait until it is before
         --  proceeding with the abortable part.
 
         --  Wait_Until_Abortable can be called unconditionally here, but it is
         --  expensive.
 
         if Entry_Call.State < Was_Abortable then
            Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
         end if;
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         --  Note: following assignment needs to be atomic
 
         Rendezvous_Successful := Entry_Call.State = Done;
      end if;
   end Task_Entry_Call;
 
   -----------------------
   -- Task_Entry_Caller --
   -----------------------
 
   function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
      Self_Id    : constant Task_Id := STPO.Self;
      Entry_Call : Entry_Call_Link;
 
   begin
      Entry_Call := Self_Id.Common.Call;
 
      for Depth in 1 .. D loop
         Entry_Call := Entry_Call.Acceptor_Prev_Call;
         pragma Assert (Entry_Call /= null);
      end loop;
 
      return Entry_Call.Self;
   end Task_Entry_Caller;
 
   --------------------------
   -- Timed_Selective_Wait --
   --------------------------
 
   procedure Timed_Selective_Wait
     (Open_Accepts       : Accept_List_Access;
      Select_Mode        : Select_Modes;
      Uninterpreted_Data : out System.Address;
      Timeout            : Duration;
      Mode               : Delay_Modes;
      Index              : out Select_Index)
   is
      Self_Id          : constant Task_Id := STPO.Self;
      Treatment        : Select_Treatment;
      Entry_Call       : Entry_Call_Link;
      Caller           : Task_Id;
      Selection        : Select_Index;
      Open_Alternative : Boolean;
      Timedout         : Boolean := False;
      Yielded          : Boolean := True;
 
   begin
      pragma Assert (Select_Mode = Delay_Mode);
 
      Initialization.Defer_Abort (Self_Id);
 
      --  If we are aborted here, the effect will be pending
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      STPO.Write_Lock (Self_Id);
 
      if not Self_Id.Callable then
         pragma Assert (Self_Id.Pending_ATC_Level = 0);
 
         pragma Assert (Self_Id.Pending_Action);
 
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         Initialization.Undefer_Abort (Self_Id);
 
         --  Should never get here ???
 
         pragma Assert (False);
         raise Standard'Abort_Signal;
      end if;
 
      Uninterpreted_Data := Null_Address;
 
      pragma Assert (Open_Accepts /= null);
 
      Queuing.Select_Task_Entry_Call
        (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
 
      --  Determine the kind and disposition of the select
 
      Treatment := Default_Treatment (Select_Mode);
      Self_Id.Chosen_Index := No_Rendezvous;
 
      if Open_Alternative then
         if Entry_Call /= null then
            if Open_Accepts (Selection).Null_Body then
               Treatment := Accept_Alternative_Completed;
 
            else
               Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
               Treatment := Accept_Alternative_Selected;
            end if;
 
            Self_Id.Chosen_Index := Selection;
 
         elsif Treatment = No_Alternative_Open then
            Treatment := Accept_Alternative_Open;
         end if;
      end if;
 
      --  Handle the select according to the disposition selected above
 
      case Treatment is
         when Accept_Alternative_Selected =>
 
            --  Ready to rendezvous. In this case the accept body is not
            --  Null_Body. Defer abort until it gets into the accept body.
 
            Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
            Initialization.Defer_Abort_Nestable (Self_Id);
            STPO.Unlock (Self_Id);
 
         when Accept_Alternative_Completed =>
 
            --  Rendezvous is over
 
            if Parameters.Runtime_Traces then
               Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
            end if;
 
            STPO.Unlock (Self_Id);
            Caller := Entry_Call.Self;
 
            STPO.Write_Lock (Caller);
            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
            STPO.Unlock (Caller);
 
         when Accept_Alternative_Open =>
 
            --  Wait for caller
 
            Self_Id.Open_Accepts := Open_Accepts;
 
            --  Wait for a normal call and a pending action until the
            --  Wakeup_Time is reached.
 
            Self_Id.Common.State := Acceptor_Delay_Sleep;
 
            --  Try to remove calls to Sleep in the loop below by letting the
            --  caller a chance of getting ready immediately, using Unlock
            --  Yield. See similar action in Wait_For_Completion/Wait_For_Call.
 
            if Single_Lock then
               Unlock_RTS;
            else
               Unlock (Self_Id);
            end if;
 
            if Self_Id.Open_Accepts /= null then
               Yield;
            end if;
 
            if Single_Lock then
               Lock_RTS;
            else
               Write_Lock (Self_Id);
            end if;
 
            --  Check if this task has been aborted while the lock was released
 
            if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
               Self_Id.Open_Accepts := null;
            end if;
 
            loop
               exit when Self_Id.Open_Accepts = null;
 
               if Timedout then
                  Sleep (Self_Id, Acceptor_Delay_Sleep);
               else
                  if Parameters.Runtime_Traces then
                     Send_Trace_Info (WT_Select,
                                      Self_Id,
                                      Integer (Open_Accepts'Length),
                                      Timeout);
                  end if;
 
                  STPO.Timed_Sleep (Self_Id, Timeout, Mode,
                    Acceptor_Delay_Sleep, Timedout, Yielded);
               end if;
 
               if Timedout then
                  Self_Id.Open_Accepts := null;
 
                  if Parameters.Runtime_Traces then
                     Send_Trace_Info (E_Timeout);
                  end if;
               end if;
            end loop;
 
            Self_Id.Common.State := Runnable;
 
            --  Self_Id.Common.Call should already be updated by the Caller if
            --  not aborted. It might also be ready to do rendezvous even if
            --  this wakes up due to an abort. Therefore, if the call is not
            --  empty we need to do the rendezvous if the accept body is not
            --  Null_Body.
 
            if Self_Id.Chosen_Index /= No_Rendezvous
              and then Self_Id.Common.Call /= null
              and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
            then
               Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 
               pragma Assert (Self_Id.Deferral_Level = 1);
 
               Initialization.Defer_Abort_Nestable (Self_Id);
 
               --  Leave abort deferred until the accept body
            end if;
 
            STPO.Unlock (Self_Id);
 
         when No_Alternative_Open =>
 
            --  In this case, Index will be No_Rendezvous on return. We sleep
            --  for the time we need to.
 
            --  Wait for a signal or timeout. A wakeup can be made
            --  for several reasons:
            --    1) Delay is expired
            --    2) Pending_Action needs to be checked
            --       (Abort, Priority change)
            --    3) Spurious wakeup
 
            Self_Id.Open_Accepts := null;
            Self_Id.Common.State := Acceptor_Delay_Sleep;
 
            STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
              Timedout, Yielded);
 
            Self_Id.Common.State := Runnable;
 
            STPO.Unlock (Self_Id);
 
         when others =>
 
            --  Should never get here
 
            pragma Assert (False);
            null;
      end case;
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      if not Yielded then
         Yield;
      end if;
 
      --  Caller has been chosen
 
      --  Self_Id.Common.Call should already be updated by the Caller
 
      --  Self_Id.Chosen_Index should either be updated by the Caller
      --  or by Test_Selective_Wait
 
      Index := Self_Id.Chosen_Index;
      Initialization.Undefer_Abort_Nestable (Self_Id);
 
      --  Start rendezvous, if not already completed
   end Timed_Selective_Wait;
 
   ---------------------------
   -- Timed_Task_Entry_Call --
   ---------------------------
 
   procedure Timed_Task_Entry_Call
     (Acceptor              : Task_Id;
      E                     : Task_Entry_Index;
      Uninterpreted_Data    : System.Address;
      Timeout               : Duration;
      Mode                  : Delay_Modes;
      Rendezvous_Successful : out Boolean)
   is
      Self_Id    : constant Task_Id := STPO.Self;
      Level      : ATC_Level;
      Entry_Call : Entry_Call_Link;
 
      Yielded : Boolean;
      pragma Unreferenced (Yielded);
 
   begin
      --  If pragma Detect_Blocking is active then Program_Error must be
      --  raised if this potentially blocking operation is called from a
      --  protected action.
 
      if System.Tasking.Detect_Blocking
        and then Self_Id.Common.Protected_Action_Nesting > 0
      then
         raise Program_Error with "potentially blocking operation";
      end if;
 
      Initialization.Defer_Abort (Self_Id);
      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
 
      pragma Debug
        (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
 
      if Parameters.Runtime_Traces then
         Send_Trace_Info (WT_Call, Acceptor,
                          Entry_Index (E), Timeout);
      end if;
 
      Level := Self_Id.ATC_Nesting_Level;
      Entry_Call := Self_Id.Entry_Calls (Level)'Access;
      Entry_Call.Next := null;
      Entry_Call.Mode := Timed_Call;
      Entry_Call.Cancellation_Attempted := False;
 
      --  If this is a call made inside of an abort deferred region,
      --  the call should be never abortable.
 
      Entry_Call.State :=
        (if Self_Id.Deferral_Level > 1
         then Never_Abortable
         else Now_Abortable);
 
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Prio := Get_Priority (Self_Id);
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
      Entry_Call.Called_Task := Acceptor;
      Entry_Call.Called_PO := Null_Address;
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
      Entry_Call.With_Abort := True;
 
      --  Note: the caller will undefer abort on return (see WARNING above)
 
      if Single_Lock then
         Lock_RTS;
      end if;
 
      if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
         STPO.Write_Lock (Self_Id);
         Utilities.Exit_One_ATC_Level (Self_Id);
         STPO.Unlock (Self_Id);
 
         if Single_Lock then
            Unlock_RTS;
         end if;
 
         Initialization.Undefer_Abort (Self_Id);
 
         if Parameters.Runtime_Traces then
            Send_Trace_Info (E_Missed, Acceptor);
         end if;
         raise Tasking_Error;
      end if;
 
      Write_Lock (Self_Id);
      Entry_Calls.Wait_For_Completion_With_Timeout
        (Entry_Call, Timeout, Mode, Yielded);
      Unlock (Self_Id);
 
      if Single_Lock then
         Unlock_RTS;
      end if;
 
      --  ??? Do we need to yield in case Yielded is False
 
      Rendezvous_Successful := Entry_Call.State = Done;
      Initialization.Undefer_Abort (Self_Id);
      Entry_Calls.Check_Exception (Self_Id, Entry_Call);
   end Timed_Task_Entry_Call;
 
   -------------------
   -- Wait_For_Call --
   -------------------
 
   procedure Wait_For_Call (Self_Id : Task_Id) is
   begin
      Self_Id.Common.State := Acceptor_Sleep;
 
      --  Try to remove calls to Sleep in the loop below by letting the caller
      --  a chance of getting ready immediately, using Unlock & Yield.
      --  See similar action in Wait_For_Completion & Timed_Selective_Wait.
 
      if Single_Lock then
         Unlock_RTS;
      else
         Unlock (Self_Id);
      end if;
 
      if Self_Id.Open_Accepts /= null then
         Yield;
      end if;
 
      if Single_Lock then
         Lock_RTS;
      else
         Write_Lock (Self_Id);
      end if;
 
      --  Check if this task has been aborted while the lock was released
 
      if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
         Self_Id.Open_Accepts := null;
      end if;
 
      loop
         exit when Self_Id.Open_Accepts = null;
         Sleep (Self_Id, Acceptor_Sleep);
      end loop;
 
      Self_Id.Common.State := Runnable;
   end Wait_For_Call;
 
end System.Tasking.Rendezvous;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasren.adb] - Blame information for rev 729

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --`
4			`-- --`
5			`-- S Y S T E M . T A S K I N G . R E N D E Z V O U S --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNARL is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNARL was developed by the GNARL team at Florida State University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies, Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`with System.Task_Primitives.Operations;`
33			`with System.Tasking.Entry_Calls;`
34			`with System.Tasking.Initialization;`
35			`with System.Tasking.Queuing;`
36			`with System.Tasking.Utilities;`
37			`with System.Tasking.Protected_Objects.Operations;`
38			`with System.Tasking.Debug;`
39			`with System.Restrictions;`
40			`with System.Parameters;`