diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/s-taenca.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/s-taenca.adb | 666 |
1 files changed, 666 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/s-taenca.adb b/gcc-4.8.3/gcc/ada/s-taenca.adb new file mode 100644 index 000000000..b1e9b640b --- /dev/null +++ b/gcc-4.8.3/gcc/ada/s-taenca.adb @@ -0,0 +1,666 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT 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 -- +-- -- +-- Copyright (C) 1992-2011, 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.Initialization; +with System.Tasking.Protected_Objects.Entries; +with System.Tasking.Protected_Objects.Operations; +with System.Tasking.Queuing; +with System.Tasking.Utilities; +with System.Parameters; +with System.Traces; + +package body System.Tasking.Entry_Calls is + + package STPO renames System.Task_Primitives.Operations; + + use Parameters; + use Task_Primitives; + use Protected_Objects.Entries; + use Protected_Objects.Operations; + use System.Traces; + + -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock + -- internally. Those operations will raise Program_Error, which + -- we 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. + -- + -- If Single_Lock and server is a PO, release RTS_Lock + -- + -- This should only be called by the Entry_Call.Self. + -- It should be holding no other ATCB locks at the time. + + procedure Unlock_Server (Entry_Call : Entry_Call_Link); + -- STPO.Unlock the server targeted by Entry_Call. The server must + -- be locked before calling this. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + 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. + -- + -- If Single_Lock and server is a PO, take RTS_Lock on exit. + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link); + -- This procedure performs priority change of a queued call and dequeuing + -- of an entry call when the call is cancelled. If the call is dequeued the + -- state should be set to Cancelled. 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 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); + -- A specialized version of Poll_Base_Priority_Change, that does the + -- optional entry queue reordering. Has to be called with the Self_ID's + -- ATCB write-locked. May temporarily release the lock. + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + pragma Warnings (Off, Self_ID); + + 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; + + ------------------------------------------ + -- Check_Pending_Actions_For_Entry_Call -- + ------------------------------------------ + + 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); + Entry_Call.State := + (if Entry_Call.Cancellation_Attempted then Cancelled else Done); + 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; + + ----------------- + -- Lock_Server -- + ----------------- + + 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. + + if Single_Lock then + STPO.Unlock_RTS; + STPO.Yield; + STPO.Lock_RTS; + else + STPO.Yield; + end if; + + else + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Lock_Entries_With_Status (Test_PO, 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.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 : constant Task_Id := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Current_Task); + Old_Base_Priority := Current_Task.Common.Base_Priority; + Current_Task.New_Base_Priority := Test_PO.Ceiling; + System.Tasking.Initialization.Change_Base_Priority + (Current_Task); + STPO.Unlock (Current_Task); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + -- Following lock should not fail + + Lock_Entries (Test_PO); + + 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; + Unlock_Entries (Test_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + 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; + + --------------------------------------------- + -- Poll_Base_Priority_Change_At_Entry_Call -- + --------------------------------------------- + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_Id; + Entry_Call : Entry_Call_Link) + is + begin + if Self_ID.Pending_Priority_Change then + + -- Check for ceiling violations ??? + + Self_ID.Pending_Priority_Change := False; + + -- Requeue the entry call at the new priority. We need to requeue + -- even if the new priority is the same than the previous (see ACATS + -- test 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; + + -------------------- + -- Reset_Priority -- + -------------------- + + procedure Reset_Priority + (Acceptor : Task_Id; + Acceptor_Prev_Priority : Rendezvous_Priority) + is + begin + pragma Assert (Acceptor = STPO.Self); + + -- Since we limit this kind of "active" priority change to be done + -- by the task for itself, we don't need to lock Acceptor. + + if Acceptor_Prev_Priority /= Priority_Not_Boosted then + STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, + Loss_Of_Inheritance => True); + end if; + end Reset_Priority; + + ------------------------------ + -- Try_To_Cancel_Entry_Call -- + ------------------------------ + + 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_xxx_Entry_Call is called. + -- That may indicate an error. Find out what is going on. ??? + + pragma Assert (Entry_Call.Mode = Asynchronous_Call); + Initialization.Defer_Abort_Nestable (Self_ID); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + 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 (Entry_Call); + STPO.Unlock (Self_ID); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Succeeded := Entry_Call.State = Cancelled; + + 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 possibility 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 Try_To_Cancel_Entry_Call; + + ------------------------------ + -- 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, False); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_And_Update_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; + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + end if; + + Unlock_Entries (Called_PO); + + if Single_Lock then + STPO.Lock_RTS; + end if; + end if; + end Unlock_Server; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is + Self_Id : constant Task_Id := Entry_Call.Self; + + begin + -- If this is a conditional call, it should be cancelled when it + -- becomes abortable. This is checked in the loop below. + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; + + Self_Id.Common.State := Entry_Caller_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_Call & Timed_Selective_Wait. + + if Single_Lock then + STPO.Unlock_RTS; + else + STPO.Unlock (Self_Id); + end if; + + if Entry_Call.State < Done then + STPO.Yield; + end if; + + if Single_Lock then + STPO.Lock_RTS; + else + STPO.Write_Lock (Self_Id); + end if; + + 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.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + procedure Wait_For_Completion_With_Timeout + (Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes; + Yielded : out Boolean) + is + Self_Id : constant Task_Id := Entry_Call.Self; + Timedout : Boolean := False; + + use type Ada.Exceptions.Exception_Id; + + begin + -- 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. + + pragma Assert (Entry_Call.Mode = Timed_Call); + + Yielded := False; + Self_Id.Common.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 same loop in the ordinary Wait_For_Completion, above. + + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Completion, Wakeup_Time); + end if; + + 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 + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + + -- Try to cancel the call (see Try_To_Cancel_Entry_Call for + -- corresponding code in the ATC case). + + Entry_Call.Cancellation_Attempted := True; + + -- Reset Entry_Call.State so that the call is marked as cancelled + -- by Check_Pending_Actions_For_Entry_Call below. + + if Entry_Call.State < Was_Abortable then + Entry_Call.State := Now_Abortable; + end if; + + 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.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + + 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. + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + + Self_Id.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_Id); + end Wait_For_Completion_With_Timeout; + + -------------------------- + -- Wait_Until_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); + + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Completion); + end if; + + STPO.Write_Lock (Self_ID); + Self_ID.Common.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.Common.State := Runnable; + STPO.Unlock (Self_ID); + + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Call_Complete); + end if; + end Wait_Until_Abortable; + +end System.Tasking.Entry_Calls; |