diff options
Diffstat (limited to 'gcc/ada/s-tasren.adb')
| -rw-r--r-- | gcc/ada/s-tasren.adb | 1052 |
1 files changed, 509 insertions, 543 deletions
diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 516cee0..9bc84b6 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,9 +6,9 @@ -- -- -- B o d y -- -- -- --- $Revision: 1.101 $ +-- $Revision$ -- -- --- Copyright (C) 1991-2001, Florida State University -- +-- Copyright (C) 1992-2001, 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- -- @@ -29,8 +29,7 @@ -- 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). -- +-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ @@ -79,14 +78,23 @@ with System.Tasking.Protected_Objects.Operations; with System.Tasking.Debug; -- used for Trace +with System.Parameters; +-- used for Single_Lock +-- Runtime_Traces + +with System.Traces.Tasking; +-- used for Send_Trace_Info + package body System.Tasking.Rendezvous is package STPO renames System.Task_Primitives.Operations; - package POO renames System.Tasking.Protected_Objects.Operations; - package POE renames System.Tasking.Protected_Objects.Entries; + package POO renames Protected_Objects.Operations; + package POE renames Protected_Objects.Entries; - use System.Task_Primitives; - use System.Task_Primitives.Operations; + 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 @@ -138,12 +146,10 @@ package body System.Tasking.Rendezvous is -- 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 + -- an earlier abort deferral. Thus, for debugging it may be -- wise to modify the above renamings to the non-nestable forms. - procedure Boost_Priority - (Call : Entry_Call_Link; - Acceptor : Task_ID); + 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. @@ -174,36 +180,13 @@ package body System.Tasking.Rendezvous is 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 abortion. + -- waiting for a call from the caller or waiting for an abort. -- Make sure Self_Id is locked before calling this routine. ----------------- -- Accept_Call -- ----------------- - -- Compiler interface only. Do not call from within the RTS. - - -- source: - -- accept E do ...A... end E; - -- expansion: - -- A27b : address; - -- L26b : label - -- begin - -- accept_call (1, A27b); - -- ...A... - -- complete_rendezvous; - -- <<L26b>> - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end; - - -- The handler for Abort_Signal (*all* others) is to handle the case when - -- the acceptor is aborted between Accept_Call and the corresponding - -- Complete_Rendezvous call. We need to wake up the caller in this case. - - -- See also Selective_Wait - procedure Accept_Call (E : Task_Entry_Index; Uninterpreted_Data : out System.Address) @@ -216,6 +199,10 @@ package body System.Tasking.Rendezvous is 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 @@ -224,6 +211,11 @@ package body System.Tasking.Rendezvous is 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 ??? @@ -232,17 +224,6 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. The logic above seems to be based on the assumption - -- that one task can safely clean up another's in-service accepts. - -- ????? - -- Why do we need to block here in this case? - -- Why not just return and let Undefer_Abort do its work? - Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); if Entry_Call /= null then @@ -259,60 +240,60 @@ package body System.Tasking.Rendezvous is -- 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.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then + if Self_Id.Common.Call /= null then Caller := Self_Id.Common.Call.Self; Uninterpreted_Data := Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; - end if; - - -- If this task has been aborted, skip the Uninterpreted_Data load - -- (Caller will not be reliable) and fall through to - -- Undefer_Abort which will allow the task to be killed. - -- ????? - -- Perhaps we could do the code anyway, if it has no harm, in order - -- to get better performance for the normal case. + 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 -- -------------------- - -- Compiler interface only. Do not call from within the RTS. - -- This should only be called when there is no accept body, - -- or the except body is empty. - - -- source: - -- accept E; - -- expansion: - -- accept_trivial (1); - - -- The compiler is also able to recognize the following and - -- translate it the same way. - - -- accept E do null; end E; - 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; + 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 @@ -321,6 +302,11 @@ package body System.Tasking.Rendezvous is 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 ??? @@ -329,23 +315,19 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. - 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')); @@ -359,7 +341,6 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Self_Id); else -- found caller already waiting - pragma Assert (Entry_Call.State < Done); STPO.Unlock (Self_Id); @@ -370,6 +351,19 @@ package body System.Tasking.Rendezvous is 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; @@ -377,10 +371,8 @@ package body System.Tasking.Rendezvous is -- Boost_Priority -- -------------------- - -- Call this only with abort deferred and holding lock of Acceptor. - procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is - Caller : Task_ID := Call.Self; + Caller : constant Task_ID := Call.Self; Caller_Prio : System.Any_Priority := Get_Priority (Caller); Acceptor_Prio : System.Any_Priority := Get_Priority (Acceptor); @@ -398,8 +390,6 @@ package body System.Tasking.Rendezvous is -- Call_Simple -- ----------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Call_Simple (Acceptor : Task_ID; E : Task_Entry_Index; @@ -415,8 +405,7 @@ package body System.Tasking.Rendezvous is -- Call_Synchronous -- ---------------------- - -- Compiler interface. - -- Also called from inside Call_Simple and Task_Entry_Call. + -- Called from Call_Simple and Task_Entry_Call. procedure Call_Synchronous (Acceptor : Task_ID; @@ -443,6 +432,10 @@ package body System.Tasking.Rendezvous is 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. @@ -458,12 +451,25 @@ package body System.Tasking.Rendezvous is Entry_Call.Called_Task := Acceptor; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - -- Note: the caller will undefer abortion on return (see WARNING above) + -- 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, With_Abort => True) then Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; + + if Single_Lock then + Unlock_RTS; + end if; + + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Missed, Acceptor); + end if; + Initialization.Undefer_Abort (Self_Id); pragma Debug (Debug.Trace (Self_Id, "CS: exited to ATC level: " & @@ -474,11 +480,16 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Self_Id); pragma Debug (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); - Entry_Calls.Wait_For_Completion (Self_Id, Entry_Call); + 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; @@ -487,19 +498,25 @@ package body System.Tasking.Rendezvous is -- Callable -- -------------- - -- Compiler interface. - -- Do not call from within the RTS, - -- except for body of Ada.Task_Identification. - function Callable (T : Task_ID) return Boolean is Result : Boolean; Self_Id : constant Task_ID := STPO.Self; begin Initialization.Defer_Abort (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 (Self_Id); return Result; end Callable; @@ -508,9 +525,6 @@ package body System.Tasking.Rendezvous is -- Cancel_Task_Entry_Call -- ---------------------------- - -- Compiler interface only. Do not call from within the RTS. - -- Call only with abort deferred. - procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is begin Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); @@ -520,8 +534,6 @@ package body System.Tasking.Rendezvous is -- Complete_Rendezvous -- ------------------------- - -- See comments for Exceptional_Complete_Rendezvous. - procedure Complete_Rendezvous is begin Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id); @@ -531,22 +543,6 @@ package body System.Tasking.Rendezvous is -- Exceptional_Complete_Rendezvous -- ------------------------------------- - -- Compiler interface. - -- Also called from Complete_Rendezvous. - -- ????? - -- Consider phasing out Complete_Rendezvous in favor - -- of direct call to this with Ada.Exceptions.Null_ID. - -- See code expansion examples for Accept_Call and Selective_Wait. - -- ????? - -- If we don't change the interface, consider instead - -- putting an explicit re-raise after this call, in - -- the generated code. That way we could eliminate the - -- code here that reraises the exception. - - -- 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. - procedure Exceptional_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is @@ -565,12 +561,28 @@ package body System.Tasking.Rendezvous is use type STPE.Protection_Entries_Access; begin + -- Consider phasing out Complete_Rendezvous in favor + -- of direct call to this with Ada.Exceptions.Null_ID. + -- See code expansion examples for Accept_Call and Selective_Wait. + -- Also consider putting an explicit re-raise after this call, in + -- the generated code. That way we could eliminate the + -- code here that reraises the exception. + + -- 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, "Exceptional_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); end if; @@ -578,6 +590,10 @@ package body System.Tasking.Rendezvous is -- 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; @@ -593,12 +609,15 @@ package body System.Tasking.Rendezvous is -- 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; @@ -612,13 +631,25 @@ package body System.Tasking.Rendezvous is 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, Entry_Call.Requeue_With_Abort) then + if Single_Lock then + Lock_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 @@ -630,11 +661,20 @@ package body System.Tasking.Rendezvous is Exception_To_Raise := Program_Error'Identity; Entry_Call.Exception_To_Raise := Exception_To_Raise; + + 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, @@ -644,14 +684,19 @@ package body System.Tasking.Rendezvous is end if; end if; - Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, - Self_Id); + 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. @@ -664,8 +709,13 @@ package body System.Tasking.Rendezvous is Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); - Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, - Self_Id); + + if Single_Lock then + Unlock_RTS; + end if; + + Entry_Calls.Reset_Priority + (Self_Id, Entry_Call.Acceptor_Prev_Priority); end if; end if; @@ -675,10 +725,8 @@ package body System.Tasking.Rendezvous is Internal_Reraise; end if; - -- ????? - -- Do we need to - -- give precedence to Program_Error that might be raised - -- due to failure of finalization, over Tasking_Error from + -- ??? 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; @@ -710,43 +758,6 @@ package body System.Tasking.Rendezvous is -- Requeue_Protected_To_Task_Entry -- ------------------------------------- - -- Compiler interface only. Do not call from within the RTS. - - -- entry e2 when b is - -- begin - -- b := false; - -- ...A... - -- requeue t.e2; - -- end e2; - - -- procedure rPT__E14b (O : address; P : address; E : - -- protected_entry_index) is - -- type rTVP is access rTV; - -- freeze rTVP [] - -- _object : rTVP := rTVP!(O); - -- begin - -- declare - -- rR : protection renames _object._object; - -- vP : integer renames _object.v; - -- bP : boolean renames _object.b; - -- begin - -- b := false; - -- ...A... - -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). - -- _task_id, 2, false); - -- return; - -- end; - -- complete_entry_body (_object._object'unchecked_access, objectF => - -- 0); - -- return; - -- exception - -- when others => - -- abort_undefer.all; - -- exceptional_complete_entry_body (_object._object' - -- unchecked_access, current_exception, objectF => 0); - -- return; - -- end rPT__E14b; - procedure Requeue_Protected_To_Task_Entry (Object : STPE.Protection_Entries_Access; Acceptor : Task_ID; @@ -768,41 +779,13 @@ package body System.Tasking.Rendezvous is -- Requeue_Task_Entry -- ------------------------ - -- Compiler interface only. Do not call from within the RTS. - -- The code generation for task entry requeues is different from that - -- for protected entry requeues. There is a "goto" that skips around - -- the call to Complete_Rendezous, so that Requeue_Task_Entry must also - -- do the work of Complete_Rendezvous. The difference is that it does - -- not report that the call's State = Done. - - -- accept e1 do - -- ...A... - -- requeue e2; - -- ...B... - -- end e1; - - -- A62b : address; - -- L61b : label - -- begin - -- accept_call (1, A62b); - -- ...A... - -- requeue_task_entry (tTV!(t)._task_id, 2, false); - -- goto L61b; - -- ...B... - -- complete_rendezvous; - -- <<L61b>> - -- exception - -- when others => - -- exceptional_complete_rendezvous (current_exception); - -- end; - 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; + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; begin Initialization.Defer_Abort (Self_Id); @@ -817,71 +800,6 @@ package body System.Tasking.Rendezvous is -- Selective_Wait -- -------------------- - -- Compiler interface only. Do not call from within the RTS. - -- See comments on Accept_Call. - - -- source code: - - -- select accept e1 do - -- ...A... - -- end e1; - -- ...B... - -- or accept e2; - -- ...C... - -- end select; - - -- expansion: - - -- A32b : address; - -- declare - -- null; - -- if accept_alternative'size * 2 >= 16#8000_0000# then - -- raise storage_error; - -- end if; - -- A37b : T36b; - -- A37b (1) := (null_body => false, s => 1); - -- A37b (2) := (null_body => true, s => 2); - -- if accept_alternative'size * 2 >= 16#8000_0000# then - -- raise storage_error; - -- end if; - -- S0 : aliased T36b := accept_list'A37b; - -- J1 : select_index := 0; - -- L3 : label - -- L1 : label - -- L2 : label - -- procedure e1A is - -- begin - -- abort_undefer.all; - -- L31b : label - -- ...A... - -- <<L31b>> - -- complete_rendezvous; - -- exception - -- when all others => - -- exceptional_complete_rendezvous (get_gnat_exception); - -- end e1A; - -- begin - -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); - -- case J1 is - -- when 0 => - -- goto L3; - -- when 1 => - -- e1A; - -- goto L1; - -- when 2 => - -- goto L2; - -- when others => - -- goto L3; - -- end case; - -- <<L1>> - -- ...B... - -- goto L3; - -- <<L2>> - -- ...C... - -- goto L3; - -- <<L3>> - -- end; - procedure Selective_Wait (Open_Accepts : Accept_List_Access; Select_Mode : Select_Modes; @@ -897,6 +815,11 @@ package body System.Tasking.Rendezvous is 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 @@ -906,8 +829,12 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Self_Id); - -- ??? In some cases abort is deferred more than once. Need to figure - -- out why. + if Single_Lock then + Unlock_RTS; + end if; + + -- ??? In some cases abort is deferred more than once. Need to + -- figure out why this happens. Self_Id.Deferral_Level := 1; @@ -919,15 +846,10 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. - pragma Assert (Open_Accepts /= null); + Uninterpreted_Data := Null_Address; + Queuing.Select_Task_Entry_Call (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); @@ -940,7 +862,6 @@ package body System.Tasking.Rendezvous is 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; @@ -953,195 +874,194 @@ package body System.Tasking.Rendezvous is end if; end if; - -- ?????? - -- Recheck the logic above against the ARM. - -- Handle the select according to the disposition selected above. case Treatment is + when Accept_Alternative_Selected => + -- Ready to rendezvous - 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 abortion - -- until it gets into the accept body. - - pragma Assert (Self_Id.Deferral_Level = 1); + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); + -- In this case the accept body is not Null_Body. Defer abort + -- until it gets into the accept body. - when Accept_Alternative_Completed => + pragma Assert (Self_Id.Deferral_Level = 1); - -- Accept body is null, so rendezvous is over immediately. + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; + when Accept_Alternative_Completed => + -- Accept body is null, so rendezvous is over immediately. - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); - - when Accept_Alternative_Open => + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; - -- Wait for caller. + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; - Self_Id.Open_Accepts := Open_Accepts; - pragma Debug - (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - Wait_For_Call (Self_Id); + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); - pragma Assert (Self_Id.Open_Accepts = null); + when Accept_Alternative_Open => + -- Wait for caller. - -- 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 abortion. - -- Therefore, if the call is not empty we need to do the rendezvous - -- if the accept body is not Null_Body. + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); - -- ????? - -- aren't the first two conditions below redundant? + if Parameters.Runtime_Traces then + Send_Trace_Info (W_Select, Self_Id, + Integer (Open_Accepts'Length)); + end if; - 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; + Wait_For_Call (Self_Id); - pragma Assert (Self_Id.Deferral_Level = 1); + pragma Assert (Self_Id.Open_Accepts = null); - Initialization.Defer_Abort_Nestable (Self_Id); + -- 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 abortion. + -- Therefore, if the call is not empty we need to do the + -- rendezvous if the accept body is not Null_Body. - -- Leave abort deferred until the accept body - end if; + -- Aren't the first two conditions below redundant??? - STPO.Unlock (Self_Id); + 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; - when Else_Selected => - pragma Assert (Self_Id.Open_Accepts = null); + pragma Assert (Self_Id.Deferral_Level = 1); - STPO.Unlock (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); - when Terminate_Selected => + -- Leave abort deferred until the accept body + end if; - -- Terminate alternative is open + STPO.Unlock (Self_Id); - Self_Id.Open_Accepts := Open_Accepts; - Self_Id.Common.State := Acceptor_Sleep; - STPO.Unlock (Self_Id); + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); - -- ????? - -- We need to check if a signal is pending on an open interrupt - -- entry. Otherwise this task would become potentially terminatable - -- and, if none of the siblings are active - -- any more, the task could not wake up any more, even though a - -- signal might be pending on an open interrupt entry. - -- ------------- - -- This comment paragraph does not make sense. Is it obsolete? - -- There was no code here to check for pending signals. + if Parameters.Runtime_Traces then + Send_Trace_Info (M_Select_Else); + end if; - -- Notify ancestors that this task is on a terminate alternative. + STPO.Unlock (Self_Id); - Utilities.Make_Passive (Self_Id, Task_Completed => False); + when Terminate_Selected => + -- Terminate alternative is open - -- Wait for normal entry call or termination + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + STPO.Unlock (Self_Id); - pragma Assert (Self_Id.ATC_Nesting_Level = 1); + -- Notify ancestors that this task is on a terminate alternative. - STPO.Write_Lock (Self_Id); + Utilities.Make_Passive (Self_Id, Task_Completed => False); - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Open_Accepts = null; - Sleep (Self_Id, Acceptor_Sleep); - end loop; + -- Wait for normal entry call or termination - Self_Id.Common.State := Runnable; + pragma Assert (Self_Id.ATC_Nesting_Level = 1); - pragma Assert (Self_Id.Open_Accepts = null); + STPO.Write_Lock (Self_Id); - if Self_Id.Terminate_Alternative then + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; - -- 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. + Self_Id.Common.State := Runnable; - pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Open_Accepts = null); - pragma Assert (Self_Id.Awake_Count = 0); + 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. - -- Trust that it is OK to fall through. + pragma Assert (Self_Id.Pending_ATC_Level = 0); + pragma Assert (Self_Id.Awake_Count = 0); - null; + -- Trust that it is OK to fall through. + null; - else - -- Self_Id.Common.Call and Self_Id.Chosen_Index - -- should already be updated by the Caller. + 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; + 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); + pragma Assert (Self_Id.Deferral_Level = 1); - -- We need an extra defer here, to keep abort - -- deferred until we get into the accept body + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body - Initialization.Defer_Abort_Nestable (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); + end if; end if; - end if; - STPO.Unlock (Self_Id); + STPO.Unlock (Self_Id); - when No_Alternative_Open => + 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. - -- 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. - -- If delay alternative exists (Delay_Mode) we should suspend - -- until the delay expires. + Self_Id.Open_Accepts := null; - Self_Id.Open_Accepts := null; + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; - if Select_Mode = Delay_Mode then - Self_Id.Common.State := Delay_Sleep; + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when + Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - 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); - Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); + else + STPO.Unlock (Self_Id); - else - STPO.Unlock (Self_Id); - Initialization.Undefer_Abort (Self_Id); - Ada.Exceptions.Raise_Exception (Program_Error'Identity, - "Entry call not a delay mode"); - end if; + if Single_Lock then + Unlock_RTS; + end if; + Initialization.Undefer_Abort (Self_Id); + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "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. + -- 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; ------------------------------------ @@ -1152,8 +1072,7 @@ package body System.Tasking.Rendezvous is procedure Setup_For_Rendezvous_With_Body (Entry_Call : Entry_Call_Link; - Acceptor : Task_ID) - is + Acceptor : Task_ID) is begin Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; Acceptor.Common.Call := Entry_Call; @@ -1169,17 +1088,25 @@ package body System.Tasking.Rendezvous is -- Task_Count -- ---------------- - -- Compiler interface only. Do not call from within the RTS. - 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; @@ -1188,56 +1115,45 @@ package body System.Tasking.Rendezvous is -- Task_Do_Or_Queue -- ---------------------- - -- Call this only with abort deferred and holding no locks. - -- May propagate an exception, including Abort_Signal & Tasking_Error. - -- ????? - -- See Check_Callable. Check all call contexts to verify - -- it is OK to raise an exception. - - -- Find out whether Entry_Call can be accepted immediately. - -- If the Acceptor is not callable, raise Tasking_Error. - -- 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. - function Task_Do_Or_Queue (Self_ID : Task_ID; Entry_Call : Entry_Call_Link; With_Abort : Boolean) 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; + 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; Parent_Locked : Boolean := False; - Null_Body : Boolean; + 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 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. -- We can't lock Acceptor.Parent while holding Acceptor, -- so lock it in advance if we expect to need to lock it. - -- ????? - -- Is there some better solution? if Acceptor.Terminate_Alternative then STPO.Write_Lock (Parent); @@ -1246,18 +1162,13 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Acceptor); - -- If the acceptor is not callable, abort the call - -- and raise Tasking_Error. The call is not aborted - -- for an asynchronous call, since Cancel_Task_Entry_Call - -- will do the cancelation in that case. - -- ????? ..... - -- Does the above still make sense? + -- If the acceptor is not callable, abort the call and return False. if not Acceptor.Callable then STPO.Unlock (Acceptor); if Parent_Locked then - STPO.Unlock (Acceptor.Common.Parent); + STPO.Unlock (Parent); end if; pragma Assert (Entry_Call.State < Done); @@ -1269,6 +1180,7 @@ package body System.Tasking.Rendezvous is 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; @@ -1291,7 +1203,6 @@ package body System.Tasking.Rendezvous is end if; if Acceptor.Terminate_Alternative then - -- Cancel terminate alternative. -- See matching code in Selective_Wait and -- Vulnerable_Complete_Master. @@ -1307,8 +1218,8 @@ package body System.Tasking.Rendezvous is Parent.Awake_Count := Parent.Awake_Count + 1; - if Parent.Common.State = Master_Completion_Sleep and then - Acceptor.Master_of_Task = Parent.Master_Within + 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; @@ -1317,7 +1228,6 @@ package body System.Tasking.Rendezvous is end if; if Null_Body then - -- Rendezvous is over immediately. STPO.Wakeup (Acceptor, Acceptor_Sleep); @@ -1379,13 +1289,12 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Parent); end if; - if Old_State /= Entry_Call.State and then - Entry_Call.State = Now_Abortable and then - Entry_Call.Mode > Simple_Call and then - - -- Asynchronous_Call or Conditional_Call + 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 - Entry_Call.Self /= Self_ID + -- Asynchronous_Call or Conditional_Call then -- Because of ATCB lock ordering rule @@ -1437,6 +1346,10 @@ package body System.Tasking.Rendezvous is Entry_Call : Entry_Call_Link; begin + 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); @@ -1466,6 +1379,10 @@ package body System.Tasking.Rendezvous is Entry_Call.Called_PO := Null_Address; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + if Single_Lock then + Lock_RTS; + end if; + if not Task_Do_Or_Queue (Self_Id, Entry_Call, With_Abort => True) then @@ -1473,7 +1390,17 @@ package body System.Tasking.Rendezvous is pragma Debug (Debug.Trace (Self_Id, "TEC: exited to ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + 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; @@ -1488,6 +1415,10 @@ package body System.Tasking.Rendezvous is 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; @@ -1498,14 +1429,13 @@ package body System.Tasking.Rendezvous is -- Task_Entry_Caller -- ----------------------- - -- Compiler interface only. - 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); @@ -1518,8 +1448,6 @@ package body System.Tasking.Rendezvous is -- Timed_Selective_Wait -- -------------------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Timed_Selective_Wait (Open_Accepts : Accept_List_Access; Select_Mode : Select_Modes; @@ -1535,7 +1463,8 @@ package body System.Tasking.Rendezvous is Selection : Select_Index; Open_Alternative : Boolean; Timedout : Boolean := False; - Yielded : Boolean := False; + Yielded : Boolean := True; + begin pragma Assert (Select_Mode = Delay_Mode); @@ -1543,6 +1472,10 @@ package body System.Tasking.Rendezvous is -- 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 @@ -1551,6 +1484,11 @@ package body System.Tasking.Rendezvous is 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 ??? @@ -1559,12 +1497,7 @@ package body System.Tasking.Rendezvous is raise Standard'Abort_Signal; end if; - -- If someone completed this task, this task should not try to - -- access its pending entry calls or queues in this case, as they - -- are being emptied. Wait for abortion to kill us. - -- ????? - -- Recheck the correctness of the above, now that we have made - -- changes. + Uninterpreted_Data := Null_Address; pragma Assert (Open_Accepts /= null); @@ -1596,115 +1529,124 @@ package body System.Tasking.Rendezvous is -- 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. - when Accept_Alternative_Selected => - - -- Ready to rendezvous - -- In this case the accept body is not Null_Body. Defer abortion - -- until it gets into the accept body. - - Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - Initialization.Defer_Abort (Self_Id); - STPO.Unlock (Self_Id); - - when Accept_Alternative_Completed => + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort (Self_Id); + STPO.Unlock (Self_Id); - -- Rendezvous is over + when Accept_Alternative_Completed => + -- Rendezvous is over - STPO.Unlock (Self_Id); - Caller := Entry_Call.Self; + if Parameters.Runtime_Traces then + Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); + end if; - STPO.Write_Lock (Caller); - Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); - STPO.Unlock (Caller); + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; - when Accept_Alternative_Open => + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); - -- Wait for caller. + when Accept_Alternative_Open => + -- Wait for caller. - Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Open_Accepts := Open_Accepts; - -- Wait for a normal call and a pending action until the - -- Wakeup_Time is reached. + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Common.State := Acceptor_Sleep; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Open_Accepts = null; + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; - if Timedout then - Sleep (Self_Id, Acceptor_Sleep); - else - STPO.Timed_Sleep (Self_Id, Timeout, Mode, - Acceptor_Sleep, Timedout, Yielded); - end if; + if Timedout then + Sleep (Self_Id, Acceptor_Sleep); + else + if Parameters.Runtime_Traces then + Send_Trace_Info (WT_Select, + Self_Id, + Integer (Open_Accepts'Length), + Timeout); + end if; - if Timedout then - Self_Id.Open_Accepts := null; - end if; - end loop; + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Sleep, Timedout, Yielded); + end if; - Self_Id.Common.State := Runnable; + if Timedout then + 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 abortion. - -- Therefore, if the call is not empty we need to do the rendezvous - -- if the accept body is not Null_Body. + if Parameters.Runtime_Traces then + Send_Trace_Info (E_Timeout); + end if; + end if; + end loop; - 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; + Self_Id.Common.State := Runnable; - pragma Assert (Self_Id.Deferral_Level = 1); + -- 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 abortion. + -- Therefore, if the call is not empty we need to do the + -- rendezvous if the accept body is not Null_Body. - Initialization.Defer_Abort_Nestable (Self_Id); + 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; - -- Leave abort deferred until the accept body + pragma Assert (Self_Id.Deferral_Level = 1); - end if; + Initialization.Defer_Abort_Nestable (Self_Id); - STPO.Unlock (Self_Id); - if not Yielded then - Yield; - end if; + -- Leave abort deferred until the accept body + end if; - when No_Alternative_Open => + STPO.Unlock (Self_Id); - -- 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 - -- (Abortion, Priority change) - -- 3) Spurious wakeup + 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 + -- (Abortion, Priority change) + -- 3) Spurious wakeup - Self_Id.Open_Accepts := null; - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Sleep; - Initialization.Poll_Base_Priority_Change (Self_Id); + Initialization.Poll_Base_Priority_Change (Self_Id); - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, - Timedout, Yielded); + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, + Timedout, Yielded); - Self_Id.Common.State := Runnable; + Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); + STPO.Unlock (Self_Id); - if not Yielded then - Yield; - end if; + when others => + -- Should never get here + pragma Assert (False); + null; + end case; - when others => - -- Should never get here ??? + if Single_Lock then + Unlock_RTS; + end if; - pragma Assert (False); - null; - end case; + if not Yielded then + Yield; + end if; -- Caller has been chosen @@ -1717,15 +1659,12 @@ package body System.Tasking.Rendezvous is Initialization.Undefer_Abort_Nestable (Self_Id); -- Start rendezvous, if not already completed - end Timed_Selective_Wait; --------------------------- -- Timed_Task_Entry_Call -- --------------------------- - -- Compiler interface only. Do not call from within the RTS. - procedure Timed_Task_Entry_Call (Acceptor : Task_ID; E : Task_Entry_Index; @@ -1737,6 +1676,7 @@ package body System.Tasking.Rendezvous is Self_Id : constant Task_ID := STPO.Self; Level : ATC_Level; Entry_Call : Entry_Call_Link; + Yielded : Boolean; begin Initialization.Defer_Abort (Self_Id); @@ -1746,6 +1686,11 @@ package body System.Tasking.Rendezvous is (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; @@ -1770,6 +1715,10 @@ package body System.Tasking.Rendezvous is -- Note: the caller will undefer abortion on return (see WARNING above) + if Single_Lock then + Lock_RTS; + end if; + if not Task_Do_Or_Queue (Self_Id, Entry_Call, With_Abort => True) then @@ -1779,12 +1728,29 @@ package body System.Tasking.Rendezvous is (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " & ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + 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 - (Self_Id, Entry_Call, Timeout, Mode); + (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); |