Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / s-tasren.adb
blob16873e85e01bf7496e8f3b3c5e92fab95f327b21
1 ------------------------------------------------------------------------------
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 ------------------------------------------------------------------------------
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;
41 with System.Traces.Tasking;
43 package body System.Tasking.Rendezvous is
45 package STPO renames System.Task_Primitives.Operations;
46 package POO renames Protected_Objects.Operations;
47 package POE renames Protected_Objects.Entries;
49 use Parameters;
50 use Task_Primitives.Operations;
51 use System.Traces;
52 use System.Traces.Tasking;
54 type Select_Treatment is (
55 Accept_Alternative_Selected, -- alternative with non-null body
56 Accept_Alternative_Completed, -- alternative with null body
57 Else_Selected,
58 Terminate_Selected,
59 Accept_Alternative_Open,
60 No_Alternative_Open);
62 ----------------
63 -- Local Data --
64 ----------------
66 Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
67 (Simple_Mode => No_Alternative_Open,
68 Else_Mode => Else_Selected,
69 Terminate_Mode => Terminate_Selected,
70 Delay_Mode => No_Alternative_Open);
72 New_State : constant array (Boolean, Entry_Call_State)
73 of Entry_Call_State :=
74 (True =>
75 (Never_Abortable => Never_Abortable,
76 Not_Yet_Abortable => Now_Abortable,
77 Was_Abortable => Now_Abortable,
78 Now_Abortable => Now_Abortable,
79 Done => Done,
80 Cancelled => Cancelled),
81 False =>
82 (Never_Abortable => Never_Abortable,
83 Not_Yet_Abortable => Not_Yet_Abortable,
84 Was_Abortable => Was_Abortable,
85 Now_Abortable => Now_Abortable,
86 Done => Done,
87 Cancelled => Cancelled)
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 procedure Local_Defer_Abort (Self_Id : Task_Id) renames
95 System.Tasking.Initialization.Defer_Abort_Nestable;
97 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
98 System.Tasking.Initialization.Undefer_Abort_Nestable;
100 -- Florist defers abort around critical sections that make entry calls
101 -- to the Interrupt_Manager task, which violates the general rule about
102 -- top-level runtime system calls from abort-deferred regions. It is not
103 -- that this is unsafe, but when it occurs in "normal" programs it usually
104 -- means either the user is trying to do a potentially blocking operation
105 -- from within a protected object, or there is a runtime system/compiler
106 -- error that has failed to undefer an earlier abort deferral. Thus, for
107 -- debugging it may be wise to modify the above renamings to the
108 -- non-nestable forms.
110 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
111 -- Internal version of Complete_Rendezvous, used to implement
112 -- Complete_Rendezvous and Exceptional_Complete_Rendezvous.
113 -- Should be called holding no locks, generally with abort
114 -- not yet deferred.
116 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
117 pragma Inline (Boost_Priority);
118 -- Call this only with abort deferred and holding lock of Acceptor
120 procedure Call_Synchronous
121 (Acceptor : Task_Id;
122 E : Task_Entry_Index;
123 Uninterpreted_Data : System.Address;
124 Mode : Call_Modes;
125 Rendezvous_Successful : out Boolean);
126 pragma Inline (Call_Synchronous);
127 -- This call is used to make a simple or conditional entry call.
128 -- Called from Call_Simple and Task_Entry_Call.
130 procedure Setup_For_Rendezvous_With_Body
131 (Entry_Call : Entry_Call_Link;
132 Acceptor : Task_Id);
133 pragma Inline (Setup_For_Rendezvous_With_Body);
134 -- Call this only with abort deferred and holding lock of Acceptor. When
135 -- a rendezvous selected (ready for rendezvous) we need to save previous
136 -- caller and adjust the priority. Also we need to make this call not
137 -- Abortable (Cancellable) since the rendezvous has already been started.
139 procedure Wait_For_Call (Self_Id : Task_Id);
140 pragma Inline (Wait_For_Call);
141 -- Call this only with abort deferred and holding lock of Self_Id. An
142 -- accepting task goes into Sleep by calling this routine waiting for a
143 -- call from the caller or waiting for an abort. Make sure Self_Id is
144 -- locked before calling this routine.
146 -----------------
147 -- Accept_Call --
148 -----------------
150 procedure Accept_Call
151 (E : Task_Entry_Index;
152 Uninterpreted_Data : out System.Address)
154 Self_Id : constant Task_Id := STPO.Self;
155 Caller : Task_Id := null;
156 Open_Accepts : aliased Accept_List (1 .. 1);
157 Entry_Call : Entry_Call_Link;
159 begin
160 Initialization.Defer_Abort (Self_Id);
162 if Single_Lock then
163 Lock_RTS;
164 end if;
166 STPO.Write_Lock (Self_Id);
168 if not Self_Id.Callable then
169 pragma Assert (Self_Id.Pending_ATC_Level = 0);
171 pragma Assert (Self_Id.Pending_Action);
173 STPO.Unlock (Self_Id);
175 if Single_Lock then
176 Unlock_RTS;
177 end if;
179 Initialization.Undefer_Abort (Self_Id);
181 -- Should never get here ???
183 pragma Assert (False);
184 raise Standard'Abort_Signal;
185 end if;
187 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
189 if Entry_Call /= null then
190 Caller := Entry_Call.Self;
191 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
192 Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
194 else
195 -- Wait for a caller
197 Open_Accepts (1).Null_Body := False;
198 Open_Accepts (1).S := E;
199 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
201 -- Wait for normal call
203 if Parameters.Runtime_Traces then
204 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
205 end if;
207 pragma Debug
208 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
209 Wait_For_Call (Self_Id);
211 pragma Assert (Self_Id.Open_Accepts = null);
213 if Self_Id.Common.Call /= null then
214 Caller := Self_Id.Common.Call.Self;
215 Uninterpreted_Data :=
216 Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
217 else
218 -- Case of an aborted task
220 Uninterpreted_Data := System.Null_Address;
221 end if;
222 end if;
224 -- Self_Id.Common.Call should already be updated by the Caller. On
225 -- return, we will start the rendezvous.
227 STPO.Unlock (Self_Id);
229 if Single_Lock then
230 Unlock_RTS;
231 end if;
233 Initialization.Undefer_Abort (Self_Id);
235 if Parameters.Runtime_Traces then
236 Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
237 end if;
238 end Accept_Call;
240 --------------------
241 -- Accept_Trivial --
242 --------------------
244 procedure Accept_Trivial (E : Task_Entry_Index) is
245 Self_Id : constant Task_Id := STPO.Self;
246 Caller : Task_Id := null;
247 Open_Accepts : aliased Accept_List (1 .. 1);
248 Entry_Call : Entry_Call_Link;
250 begin
251 Initialization.Defer_Abort_Nestable (Self_Id);
253 if Single_Lock then
254 Lock_RTS;
255 end if;
257 STPO.Write_Lock (Self_Id);
259 if not Self_Id.Callable then
260 pragma Assert (Self_Id.Pending_ATC_Level = 0);
262 pragma Assert (Self_Id.Pending_Action);
264 STPO.Unlock (Self_Id);
266 if Single_Lock then
267 Unlock_RTS;
268 end if;
270 Initialization.Undefer_Abort_Nestable (Self_Id);
272 -- Should never get here ???
274 pragma Assert (False);
275 raise Standard'Abort_Signal;
276 end if;
278 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
280 if Entry_Call = null then
282 -- Need to wait for entry call
284 Open_Accepts (1).Null_Body := True;
285 Open_Accepts (1).S := E;
286 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
288 if Parameters.Runtime_Traces then
289 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
290 end if;
292 pragma Debug
293 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
295 Wait_For_Call (Self_Id);
297 pragma Assert (Self_Id.Open_Accepts = null);
299 -- No need to do anything special here for pending abort.
300 -- Abort_Signal will be raised by Undefer on exit.
302 STPO.Unlock (Self_Id);
304 -- Found caller already waiting
306 else
307 pragma Assert (Entry_Call.State < Done);
309 STPO.Unlock (Self_Id);
310 Caller := Entry_Call.Self;
312 STPO.Write_Lock (Caller);
313 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
314 STPO.Unlock (Caller);
315 end if;
317 if Parameters.Runtime_Traces then
318 Send_Trace_Info (M_Accept_Complete);
320 -- Fake one, since there is (???) no way to know that the rendezvous
321 -- is over.
323 Send_Trace_Info (M_RDV_Complete);
324 end if;
326 if Single_Lock then
327 Unlock_RTS;
328 end if;
330 Initialization.Undefer_Abort_Nestable (Self_Id);
331 end Accept_Trivial;
333 --------------------
334 -- Boost_Priority --
335 --------------------
337 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
338 Caller : constant Task_Id := Call.Self;
339 Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
340 Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
341 begin
342 if Caller_Prio > Acceptor_Prio then
343 Call.Acceptor_Prev_Priority := Acceptor_Prio;
344 Set_Priority (Acceptor, Caller_Prio);
345 else
346 Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
347 end if;
348 end Boost_Priority;
350 -----------------
351 -- Call_Simple --
352 -----------------
354 procedure Call_Simple
355 (Acceptor : Task_Id;
356 E : Task_Entry_Index;
357 Uninterpreted_Data : System.Address)
359 Rendezvous_Successful : Boolean;
360 pragma Unreferenced (Rendezvous_Successful);
362 begin
363 -- If pragma Detect_Blocking is active then Program_Error must be
364 -- raised if this potentially blocking operation is called from a
365 -- protected action.
367 if System.Tasking.Detect_Blocking
368 and then STPO.Self.Common.Protected_Action_Nesting > 0
369 then
370 raise Program_Error with "potentially blocking operation";
371 end if;
373 Call_Synchronous
374 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
375 end Call_Simple;
377 ----------------------
378 -- Call_Synchronous --
379 ----------------------
381 procedure Call_Synchronous
382 (Acceptor : Task_Id;
383 E : Task_Entry_Index;
384 Uninterpreted_Data : System.Address;
385 Mode : Call_Modes;
386 Rendezvous_Successful : out Boolean)
388 Self_Id : constant Task_Id := STPO.Self;
389 Level : ATC_Level;
390 Entry_Call : Entry_Call_Link;
392 begin
393 pragma Assert (Mode /= Asynchronous_Call);
395 Local_Defer_Abort (Self_Id);
396 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
397 pragma Debug
398 (Debug.Trace (Self_Id, "CS: entered ATC level: " &
399 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
400 Level := Self_Id.ATC_Nesting_Level;
401 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
402 Entry_Call.Next := null;
403 Entry_Call.Mode := Mode;
404 Entry_Call.Cancellation_Attempted := False;
406 if Parameters.Runtime_Traces then
407 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
408 end if;
410 -- If this is a call made inside of an abort deferred region,
411 -- the call should be never abortable.
413 Entry_Call.State :=
414 (if Self_Id.Deferral_Level > 1
415 then Never_Abortable
416 else Now_Abortable);
418 Entry_Call.E := Entry_Index (E);
419 Entry_Call.Prio := Get_Priority (Self_Id);
420 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
421 Entry_Call.Called_Task := Acceptor;
422 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
423 Entry_Call.With_Abort := True;
425 -- Note: the caller will undefer abort on return (see WARNING above)
427 if Single_Lock then
428 Lock_RTS;
429 end if;
431 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
432 STPO.Write_Lock (Self_Id);
433 Utilities.Exit_One_ATC_Level (Self_Id);
434 STPO.Unlock (Self_Id);
436 if Single_Lock then
437 Unlock_RTS;
438 end if;
440 if Parameters.Runtime_Traces then
441 Send_Trace_Info (E_Missed, Acceptor);
442 end if;
444 Local_Undefer_Abort (Self_Id);
445 raise Tasking_Error;
446 end if;
448 STPO.Write_Lock (Self_Id);
449 pragma Debug
450 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
451 Entry_Calls.Wait_For_Completion (Entry_Call);
452 pragma Debug
453 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
454 Rendezvous_Successful := Entry_Call.State = Done;
455 STPO.Unlock (Self_Id);
457 if Single_Lock then
458 Unlock_RTS;
459 end if;
461 Local_Undefer_Abort (Self_Id);
462 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
463 end Call_Synchronous;
465 --------------
466 -- Callable --
467 --------------
469 function Callable (T : Task_Id) return Boolean is
470 Result : Boolean;
471 Self_Id : constant Task_Id := STPO.Self;
473 begin
474 Initialization.Defer_Abort_Nestable (Self_Id);
476 if Single_Lock then
477 Lock_RTS;
478 end if;
480 STPO.Write_Lock (T);
481 Result := T.Callable;
482 STPO.Unlock (T);
484 if Single_Lock then
485 Unlock_RTS;
486 end if;
488 Initialization.Undefer_Abort_Nestable (Self_Id);
489 return Result;
490 end Callable;
492 ----------------------------
493 -- Cancel_Task_Entry_Call --
494 ----------------------------
496 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
497 begin
498 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
499 end Cancel_Task_Entry_Call;
501 -------------------------
502 -- Complete_Rendezvous --
503 -------------------------
505 procedure Complete_Rendezvous is
506 begin
507 Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
508 end Complete_Rendezvous;
510 -------------------------------------
511 -- Exceptional_Complete_Rendezvous --
512 -------------------------------------
514 procedure Exceptional_Complete_Rendezvous
515 (Ex : Ada.Exceptions.Exception_Id)
517 procedure Internal_Reraise;
518 pragma No_Return (Internal_Reraise);
519 pragma Import (C, Internal_Reraise, "__gnat_reraise");
521 begin
522 Local_Complete_Rendezvous (Ex);
523 Internal_Reraise;
525 -- ??? Do we need to give precedence to Program_Error that might be
526 -- raised due to failure of finalization, over Tasking_Error from
527 -- failure of requeue?
528 end Exceptional_Complete_Rendezvous;
530 -------------------------------
531 -- Local_Complete_Rendezvous --
532 -------------------------------
534 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
535 Self_Id : constant Task_Id := STPO.Self;
536 Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
537 Caller : Task_Id;
538 Called_PO : STPE.Protection_Entries_Access;
539 Acceptor_Prev_Priority : Integer;
541 Ceiling_Violation : Boolean;
543 use type Ada.Exceptions.Exception_Id;
544 procedure Transfer_Occurrence
545 (Target : Ada.Exceptions.Exception_Occurrence_Access;
546 Source : Ada.Exceptions.Exception_Occurrence);
547 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
549 use type STPE.Protection_Entries_Access;
551 begin
552 -- The deferral level is critical here, since we want to raise an
553 -- exception or allow abort to take place, if there is an exception or
554 -- abort pending.
556 pragma Debug
557 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
559 if Ex = Ada.Exceptions.Null_Id then
561 -- The call came from normal end-of-rendezvous, so abort is not yet
562 -- deferred.
564 if Parameters.Runtime_Traces then
565 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
566 end if;
568 Initialization.Defer_Abort_Nestable (Self_Id);
570 elsif ZCX_By_Default then
572 -- With ZCX, aborts are not automatically deferred in handlers
574 Initialization.Defer_Abort_Nestable (Self_Id);
575 end if;
577 -- We need to clean up any accepts which Self may have been serving when
578 -- it was aborted.
580 if Ex = Standard'Abort_Signal'Identity then
581 if Single_Lock then
582 Lock_RTS;
583 end if;
585 while Entry_Call /= null loop
586 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
588 -- All forms of accept make sure that the acceptor is not
589 -- completed, before accepting further calls, so that we
590 -- can be sure that no further calls are made after the
591 -- current calls are purged.
593 Caller := Entry_Call.Self;
595 -- Take write lock. This follows the lock precedence rule that
596 -- Caller may be locked while holding lock of Acceptor. Complete
597 -- the call abnormally, with exception.
599 STPO.Write_Lock (Caller);
600 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
601 STPO.Unlock (Caller);
602 Entry_Call := Entry_Call.Acceptor_Prev_Call;
603 end loop;
605 if Single_Lock then
606 Unlock_RTS;
607 end if;
609 else
610 Caller := Entry_Call.Self;
612 if Entry_Call.Needs_Requeue then
614 -- We dare not lock Self_Id at the same time as Caller, for fear
615 -- of deadlock.
617 Entry_Call.Needs_Requeue := False;
618 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
620 if Entry_Call.Called_Task /= null then
622 -- Requeue to another task entry
624 if Single_Lock then
625 Lock_RTS;
626 end if;
628 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
629 if Single_Lock then
630 Unlock_RTS;
631 end if;
633 Initialization.Undefer_Abort (Self_Id);
634 raise Tasking_Error;
635 end if;
637 if Single_Lock then
638 Unlock_RTS;
639 end if;
641 else
642 -- Requeue to a protected entry
644 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
645 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
647 if Ceiling_Violation then
648 pragma Assert (Ex = Ada.Exceptions.Null_Id);
649 Entry_Call.Exception_To_Raise := Program_Error'Identity;
651 if Single_Lock then
652 Lock_RTS;
653 end if;
655 STPO.Write_Lock (Caller);
656 Initialization.Wakeup_Entry_Caller
657 (Self_Id, Entry_Call, Done);
658 STPO.Unlock (Caller);
660 if Single_Lock then
661 Unlock_RTS;
662 end if;
664 else
665 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
666 POO.PO_Service_Entries (Self_Id, Called_PO);
667 end if;
668 end if;
670 Entry_Calls.Reset_Priority
671 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
673 else
674 -- The call does not need to be requeued
676 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
677 Entry_Call.Exception_To_Raise := Ex;
679 if Single_Lock then
680 Lock_RTS;
681 end if;
683 STPO.Write_Lock (Caller);
685 -- Done with Caller locked to make sure that Wakeup is not lost
687 if Ex /= Ada.Exceptions.Null_Id then
688 Transfer_Occurrence
689 (Caller.Common.Compiler_Data.Current_Excep'Access,
690 Self_Id.Common.Compiler_Data.Current_Excep);
691 end if;
693 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
694 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
696 STPO.Unlock (Caller);
698 if Single_Lock then
699 Unlock_RTS;
700 end if;
702 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
703 end if;
704 end if;
706 Initialization.Undefer_Abort (Self_Id);
707 end Local_Complete_Rendezvous;
709 -------------------------------------
710 -- Requeue_Protected_To_Task_Entry --
711 -------------------------------------
713 procedure Requeue_Protected_To_Task_Entry
714 (Object : STPE.Protection_Entries_Access;
715 Acceptor : Task_Id;
716 E : Task_Entry_Index;
717 With_Abort : Boolean)
719 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
720 begin
721 pragma Assert (STPO.Self.Deferral_Level > 0);
723 Entry_Call.E := Entry_Index (E);
724 Entry_Call.Called_Task := Acceptor;
725 Entry_Call.Called_PO := Null_Address;
726 Entry_Call.With_Abort := With_Abort;
727 Object.Call_In_Progress := null;
728 end Requeue_Protected_To_Task_Entry;
730 ------------------------
731 -- Requeue_Task_Entry --
732 ------------------------
734 procedure Requeue_Task_Entry
735 (Acceptor : Task_Id;
736 E : Task_Entry_Index;
737 With_Abort : Boolean)
739 Self_Id : constant Task_Id := STPO.Self;
740 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
741 begin
742 Initialization.Defer_Abort (Self_Id);
743 Entry_Call.Needs_Requeue := True;
744 Entry_Call.With_Abort := With_Abort;
745 Entry_Call.E := Entry_Index (E);
746 Entry_Call.Called_Task := Acceptor;
747 Initialization.Undefer_Abort (Self_Id);
748 end Requeue_Task_Entry;
750 --------------------
751 -- Selective_Wait --
752 --------------------
754 procedure Selective_Wait
755 (Open_Accepts : Accept_List_Access;
756 Select_Mode : Select_Modes;
757 Uninterpreted_Data : out System.Address;
758 Index : out Select_Index)
760 Self_Id : constant Task_Id := STPO.Self;
761 Entry_Call : Entry_Call_Link;
762 Treatment : Select_Treatment;
763 Caller : Task_Id;
764 Selection : Select_Index;
765 Open_Alternative : Boolean;
767 begin
768 Initialization.Defer_Abort (Self_Id);
770 if Single_Lock then
771 Lock_RTS;
772 end if;
774 STPO.Write_Lock (Self_Id);
776 if not Self_Id.Callable then
777 pragma Assert (Self_Id.Pending_ATC_Level = 0);
779 pragma Assert (Self_Id.Pending_Action);
781 STPO.Unlock (Self_Id);
783 if Single_Lock then
784 Unlock_RTS;
785 end if;
787 -- ??? In some cases abort is deferred more than once. Need to
788 -- figure out why this happens.
790 if Self_Id.Deferral_Level > 1 then
791 Self_Id.Deferral_Level := 1;
792 end if;
794 Initialization.Undefer_Abort (Self_Id);
796 -- Should never get here ???
798 pragma Assert (False);
799 raise Standard'Abort_Signal;
800 end if;
802 pragma Assert (Open_Accepts /= null);
804 Uninterpreted_Data := Null_Address;
806 Queuing.Select_Task_Entry_Call
807 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
809 -- Determine the kind and disposition of the select
811 Treatment := Default_Treatment (Select_Mode);
812 Self_Id.Chosen_Index := No_Rendezvous;
814 if Open_Alternative then
815 if Entry_Call /= null then
816 if Open_Accepts (Selection).Null_Body then
817 Treatment := Accept_Alternative_Completed;
818 else
819 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
820 Treatment := Accept_Alternative_Selected;
821 end if;
823 Self_Id.Chosen_Index := Selection;
825 elsif Treatment = No_Alternative_Open then
826 Treatment := Accept_Alternative_Open;
827 end if;
828 end if;
830 -- Handle the select according to the disposition selected above
832 case Treatment is
833 when Accept_Alternative_Selected =>
835 -- Ready to rendezvous
837 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
839 -- In this case the accept body is not Null_Body. Defer abort
840 -- until it gets into the accept body.
842 pragma Assert (Self_Id.Deferral_Level = 1);
844 Initialization.Defer_Abort_Nestable (Self_Id);
845 STPO.Unlock (Self_Id);
847 when Accept_Alternative_Completed =>
849 -- Accept body is null, so rendezvous is over immediately
851 if Parameters.Runtime_Traces then
852 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
853 end if;
855 STPO.Unlock (Self_Id);
856 Caller := Entry_Call.Self;
858 STPO.Write_Lock (Caller);
859 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
860 STPO.Unlock (Caller);
862 when Accept_Alternative_Open =>
864 -- Wait for caller
866 Self_Id.Open_Accepts := Open_Accepts;
867 pragma Debug
868 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
870 if Parameters.Runtime_Traces then
871 Send_Trace_Info (W_Select, Self_Id,
872 Integer (Open_Accepts'Length));
873 end if;
875 Wait_For_Call (Self_Id);
877 pragma Assert (Self_Id.Open_Accepts = null);
879 -- Self_Id.Common.Call should already be updated by the Caller if
880 -- not aborted. It might also be ready to do rendezvous even if
881 -- this wakes up due to an abort. Therefore, if the call is not
882 -- empty we need to do the rendezvous if the accept body is not
883 -- Null_Body.
885 -- Aren't the first two conditions below redundant???
887 if Self_Id.Chosen_Index /= No_Rendezvous
888 and then Self_Id.Common.Call /= null
889 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
890 then
891 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
893 pragma Assert
894 (Self_Id.Deferral_Level = 1
895 or else
896 (Self_Id.Deferral_Level = 0
897 and then not Restrictions.Abort_Allowed));
899 Initialization.Defer_Abort_Nestable (Self_Id);
901 -- Leave abort deferred until the accept body
902 end if;
904 STPO.Unlock (Self_Id);
906 when Else_Selected =>
907 pragma Assert (Self_Id.Open_Accepts = null);
909 if Parameters.Runtime_Traces then
910 Send_Trace_Info (M_Select_Else);
911 end if;
913 STPO.Unlock (Self_Id);
915 when Terminate_Selected =>
917 -- Terminate alternative is open
919 Self_Id.Open_Accepts := Open_Accepts;
920 Self_Id.Common.State := Acceptor_Sleep;
922 -- Notify ancestors that this task is on a terminate alternative
924 STPO.Unlock (Self_Id);
925 Utilities.Make_Passive (Self_Id, Task_Completed => False);
926 STPO.Write_Lock (Self_Id);
928 -- Wait for normal entry call or termination
930 Wait_For_Call (Self_Id);
932 pragma Assert (Self_Id.Open_Accepts = null);
934 if Self_Id.Terminate_Alternative then
936 -- An entry call should have reset this to False, so we must be
937 -- aborted. We cannot be in an async. select, since that is not
938 -- legal, so the abort must be of the entire task. Therefore,
939 -- we do not need to cancel the terminate alternative. The
940 -- cleanup will be done in Complete_Master.
942 pragma Assert (Self_Id.Pending_ATC_Level = 0);
943 pragma Assert (Self_Id.Awake_Count = 0);
945 STPO.Unlock (Self_Id);
947 if Single_Lock then
948 Unlock_RTS;
949 end if;
951 Index := Self_Id.Chosen_Index;
952 Initialization.Undefer_Abort_Nestable (Self_Id);
954 if Self_Id.Pending_Action then
955 Initialization.Do_Pending_Action (Self_Id);
956 end if;
958 return;
960 else
961 -- Self_Id.Common.Call and Self_Id.Chosen_Index
962 -- should already be updated by the Caller.
964 if Self_Id.Chosen_Index /= No_Rendezvous
965 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
966 then
967 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
969 pragma Assert (Self_Id.Deferral_Level = 1);
971 -- We need an extra defer here, to keep abort
972 -- deferred until we get into the accept body
974 Initialization.Defer_Abort_Nestable (Self_Id);
975 end if;
976 end if;
978 STPO.Unlock (Self_Id);
980 when No_Alternative_Open =>
982 -- In this case, Index will be No_Rendezvous on return, which
983 -- should cause a Program_Error if it is not a Delay_Mode.
985 -- If delay alternative exists (Delay_Mode) we should suspend
986 -- until the delay expires.
988 Self_Id.Open_Accepts := null;
990 if Select_Mode = Delay_Mode then
991 Self_Id.Common.State := Delay_Sleep;
993 loop
994 exit when
995 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
996 Sleep (Self_Id, Delay_Sleep);
997 end loop;
999 Self_Id.Common.State := Runnable;
1000 STPO.Unlock (Self_Id);
1002 else
1003 STPO.Unlock (Self_Id);
1005 if Single_Lock then
1006 Unlock_RTS;
1007 end if;
1009 Initialization.Undefer_Abort (Self_Id);
1010 raise Program_Error with "Entry call not a delay mode";
1011 end if;
1012 end case;
1014 if Single_Lock then
1015 Unlock_RTS;
1016 end if;
1018 -- Caller has been chosen
1020 -- Self_Id.Common.Call should already be updated by the Caller.
1022 -- Self_Id.Chosen_Index should either be updated by the Caller
1023 -- or by Test_Selective_Wait.
1025 -- On return, we sill start rendezvous unless the accept body is
1026 -- null. In the latter case, we will have already completed the RV.
1028 Index := Self_Id.Chosen_Index;
1029 Initialization.Undefer_Abort_Nestable (Self_Id);
1030 end Selective_Wait;
1032 ------------------------------------
1033 -- Setup_For_Rendezvous_With_Body --
1034 ------------------------------------
1036 procedure Setup_For_Rendezvous_With_Body
1037 (Entry_Call : Entry_Call_Link;
1038 Acceptor : Task_Id) is
1039 begin
1040 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1041 Acceptor.Common.Call := Entry_Call;
1043 if Entry_Call.State = Now_Abortable then
1044 Entry_Call.State := Was_Abortable;
1045 end if;
1047 Boost_Priority (Entry_Call, Acceptor);
1048 end Setup_For_Rendezvous_With_Body;
1050 ----------------
1051 -- Task_Count --
1052 ----------------
1054 function Task_Count (E : Task_Entry_Index) return Natural is
1055 Self_Id : constant Task_Id := STPO.Self;
1056 Return_Count : Natural;
1058 begin
1059 Initialization.Defer_Abort (Self_Id);
1061 if Single_Lock then
1062 Lock_RTS;
1063 end if;
1065 STPO.Write_Lock (Self_Id);
1066 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1067 STPO.Unlock (Self_Id);
1069 if Single_Lock then
1070 Unlock_RTS;
1071 end if;
1073 Initialization.Undefer_Abort (Self_Id);
1075 return Return_Count;
1076 end Task_Count;
1078 ----------------------
1079 -- Task_Do_Or_Queue --
1080 ----------------------
1082 function Task_Do_Or_Queue
1083 (Self_ID : Task_Id;
1084 Entry_Call : Entry_Call_Link) return Boolean
1086 E : constant Task_Entry_Index :=
1087 Task_Entry_Index (Entry_Call.E);
1088 Old_State : constant Entry_Call_State := Entry_Call.State;
1089 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1090 Parent : constant Task_Id := Acceptor.Common.Parent;
1091 Null_Body : Boolean;
1093 begin
1094 -- Find out whether Entry_Call can be accepted immediately
1096 -- If the Acceptor is not callable, return False.
1097 -- If the rendezvous can start, initiate it.
1098 -- If the accept-body is trivial, also complete the rendezvous.
1099 -- If the acceptor is not ready, enqueue the call.
1101 -- This should have a special case for Accept_Call and Accept_Trivial,
1102 -- so that we don't have the loop setup overhead, below.
1104 -- The call state Done is used here and elsewhere to include both the
1105 -- case of normal successful completion, and the case of an exception
1106 -- being raised. The difference is that if an exception is raised no one
1107 -- will pay attention to the fact that State = Done. Instead the
1108 -- exception will be raised in Undefer_Abort, and control will skip past
1109 -- the place where we normally would resume from an entry call.
1111 pragma Assert (not Queuing.Onqueue (Entry_Call));
1113 -- We rely that the call is off-queue for protection, that the caller
1114 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1115 -- record for another call. We rely on the Caller's lock for call State
1116 -- mod's.
1118 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1119 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1120 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor
1121 -- is locked. Therefore, we need to lock both. Attempts to avoid locking
1122 -- Parent tend to result in race conditions. It would work to unlock
1123 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be
1124 -- False, but that violates the rule of properly nested locking (see
1125 -- System.Tasking).
1127 STPO.Write_Lock (Parent);
1128 STPO.Write_Lock (Acceptor);
1130 -- If the acceptor is not callable, abort the call and return False
1132 if not Acceptor.Callable then
1133 STPO.Unlock (Acceptor);
1134 STPO.Unlock (Parent);
1136 pragma Assert (Entry_Call.State < Done);
1138 -- In case we are not the caller, set up the caller
1139 -- to raise Tasking_Error when it wakes up.
1141 STPO.Write_Lock (Entry_Call.Self);
1142 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1143 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1144 STPO.Unlock (Entry_Call.Self);
1146 return False;
1147 end if;
1149 -- Try to serve the call immediately
1151 if Acceptor.Open_Accepts /= null then
1152 for J in Acceptor.Open_Accepts'Range loop
1153 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1155 -- Commit acceptor to rendezvous with us
1157 Acceptor.Chosen_Index := J;
1158 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1159 Acceptor.Open_Accepts := null;
1161 -- Prevent abort while call is being served
1163 if Entry_Call.State = Now_Abortable then
1164 Entry_Call.State := Was_Abortable;
1165 end if;
1167 if Acceptor.Terminate_Alternative then
1169 -- Cancel terminate alternative. See matching code in
1170 -- Selective_Wait and Vulnerable_Complete_Master.
1172 Acceptor.Terminate_Alternative := False;
1173 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1175 if Acceptor.Awake_Count = 1 then
1177 -- Notify parent that acceptor is awake
1179 pragma Assert (Parent.Awake_Count > 0);
1181 Parent.Awake_Count := Parent.Awake_Count + 1;
1183 if Parent.Common.State = Master_Completion_Sleep
1184 and then Acceptor.Master_of_Task = Parent.Master_Within
1185 then
1186 Parent.Common.Wait_Count :=
1187 Parent.Common.Wait_Count + 1;
1188 end if;
1189 end if;
1190 end if;
1192 if Null_Body then
1194 -- Rendezvous is over immediately
1196 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1197 STPO.Unlock (Acceptor);
1198 STPO.Unlock (Parent);
1200 STPO.Write_Lock (Entry_Call.Self);
1201 Initialization.Wakeup_Entry_Caller
1202 (Self_ID, Entry_Call, Done);
1203 STPO.Unlock (Entry_Call.Self);
1205 else
1206 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1208 -- For terminate_alternative, acceptor may not be asleep
1209 -- yet, so we skip the wakeup
1211 if Acceptor.Common.State /= Runnable then
1212 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1213 end if;
1215 STPO.Unlock (Acceptor);
1216 STPO.Unlock (Parent);
1217 end if;
1219 return True;
1220 end if;
1221 end loop;
1223 -- The acceptor is accepting, but not this entry
1224 end if;
1226 -- If the acceptor was ready to accept this call,
1227 -- we would not have gotten this far, so now we should
1228 -- (re)enqueue the call, if the mode permits that.
1230 -- If the call is timed, it may have timed out before the requeue,
1231 -- in the unusual case where the current accept has taken longer than
1232 -- the given delay. In that case the requeue is cancelled, and the
1233 -- outer timed call will be aborted.
1235 if Entry_Call.Mode = Conditional_Call
1236 or else
1237 (Entry_Call.Mode = Timed_Call
1238 and then Entry_Call.With_Abort
1239 and then Entry_Call.Cancellation_Attempted)
1240 then
1241 STPO.Unlock (Acceptor);
1242 STPO.Unlock (Parent);
1244 STPO.Write_Lock (Entry_Call.Self);
1246 pragma Assert (Entry_Call.State >= Was_Abortable);
1248 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1249 STPO.Unlock (Entry_Call.Self);
1251 else
1252 -- Timed_Call, Simple_Call, or Asynchronous_Call
1254 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1256 -- Update abortability of call
1258 pragma Assert (Old_State < Done);
1260 Entry_Call.State :=
1261 New_State (Entry_Call.With_Abort, Entry_Call.State);
1263 STPO.Unlock (Acceptor);
1264 STPO.Unlock (Parent);
1266 if Old_State /= Entry_Call.State
1267 and then Entry_Call.State = Now_Abortable
1268 and then Entry_Call.Mode /= Simple_Call
1269 and then Entry_Call.Self /= Self_ID
1271 -- Asynchronous_Call or Conditional_Call
1273 then
1274 -- Because of ATCB lock ordering rule
1276 STPO.Write_Lock (Entry_Call.Self);
1278 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1280 -- Caller may not yet have reached wait-point
1282 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1283 end if;
1285 STPO.Unlock (Entry_Call.Self);
1286 end if;
1287 end if;
1289 return True;
1290 end Task_Do_Or_Queue;
1292 ---------------------
1293 -- Task_Entry_Call --
1294 ---------------------
1296 procedure Task_Entry_Call
1297 (Acceptor : Task_Id;
1298 E : Task_Entry_Index;
1299 Uninterpreted_Data : System.Address;
1300 Mode : Call_Modes;
1301 Rendezvous_Successful : out Boolean)
1303 Self_Id : constant Task_Id := STPO.Self;
1304 Entry_Call : Entry_Call_Link;
1306 begin
1307 -- If pragma Detect_Blocking is active then Program_Error must be
1308 -- raised if this potentially blocking operation is called from a
1309 -- protected action.
1311 if System.Tasking.Detect_Blocking
1312 and then Self_Id.Common.Protected_Action_Nesting > 0
1313 then
1314 raise Program_Error with "potentially blocking operation";
1315 end if;
1317 if Parameters.Runtime_Traces then
1318 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1319 end if;
1321 if Mode = Simple_Call or else Mode = Conditional_Call then
1322 Call_Synchronous
1323 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1325 else
1326 -- This is an asynchronous call
1328 -- Abort must already be deferred by the compiler-generated code.
1329 -- Without this, an abort that occurs between the time that this
1330 -- call is made and the time that the abortable part's cleanup
1331 -- handler is set up might miss the cleanup handler and leave the
1332 -- call pending.
1334 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1335 pragma Debug
1336 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1337 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1338 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1339 Entry_Call.Next := null;
1340 Entry_Call.Mode := Mode;
1341 Entry_Call.Cancellation_Attempted := False;
1342 Entry_Call.State := Not_Yet_Abortable;
1343 Entry_Call.E := Entry_Index (E);
1344 Entry_Call.Prio := Get_Priority (Self_Id);
1345 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1346 Entry_Call.Called_Task := Acceptor;
1347 Entry_Call.Called_PO := Null_Address;
1348 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1349 Entry_Call.With_Abort := True;
1351 if Single_Lock then
1352 Lock_RTS;
1353 end if;
1355 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1356 STPO.Write_Lock (Self_Id);
1357 Utilities.Exit_One_ATC_Level (Self_Id);
1358 STPO.Unlock (Self_Id);
1360 if Single_Lock then
1361 Unlock_RTS;
1362 end if;
1364 Initialization.Undefer_Abort (Self_Id);
1366 if Parameters.Runtime_Traces then
1367 Send_Trace_Info (E_Missed, Acceptor);
1368 end if;
1370 raise Tasking_Error;
1371 end if;
1373 -- The following is special for async. entry calls. If the call was
1374 -- not queued abortably, we need to wait until it is before
1375 -- proceeding with the abortable part.
1377 -- Wait_Until_Abortable can be called unconditionally here, but it is
1378 -- expensive.
1380 if Entry_Call.State < Was_Abortable then
1381 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1382 end if;
1384 if Single_Lock then
1385 Unlock_RTS;
1386 end if;
1388 -- Note: following assignment needs to be atomic
1390 Rendezvous_Successful := Entry_Call.State = Done;
1391 end if;
1392 end Task_Entry_Call;
1394 -----------------------
1395 -- Task_Entry_Caller --
1396 -----------------------
1398 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1399 Self_Id : constant Task_Id := STPO.Self;
1400 Entry_Call : Entry_Call_Link;
1402 begin
1403 Entry_Call := Self_Id.Common.Call;
1405 for Depth in 1 .. D loop
1406 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1407 pragma Assert (Entry_Call /= null);
1408 end loop;
1410 return Entry_Call.Self;
1411 end Task_Entry_Caller;
1413 --------------------------
1414 -- Timed_Selective_Wait --
1415 --------------------------
1417 procedure Timed_Selective_Wait
1418 (Open_Accepts : Accept_List_Access;
1419 Select_Mode : Select_Modes;
1420 Uninterpreted_Data : out System.Address;
1421 Timeout : Duration;
1422 Mode : Delay_Modes;
1423 Index : out Select_Index)
1425 Self_Id : constant Task_Id := STPO.Self;
1426 Treatment : Select_Treatment;
1427 Entry_Call : Entry_Call_Link;
1428 Caller : Task_Id;
1429 Selection : Select_Index;
1430 Open_Alternative : Boolean;
1431 Timedout : Boolean := False;
1432 Yielded : Boolean := True;
1434 begin
1435 pragma Assert (Select_Mode = Delay_Mode);
1437 Initialization.Defer_Abort (Self_Id);
1439 -- If we are aborted here, the effect will be pending
1441 if Single_Lock then
1442 Lock_RTS;
1443 end if;
1445 STPO.Write_Lock (Self_Id);
1447 if not Self_Id.Callable then
1448 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1450 pragma Assert (Self_Id.Pending_Action);
1452 STPO.Unlock (Self_Id);
1454 if Single_Lock then
1455 Unlock_RTS;
1456 end if;
1458 Initialization.Undefer_Abort (Self_Id);
1460 -- Should never get here ???
1462 pragma Assert (False);
1463 raise Standard'Abort_Signal;
1464 end if;
1466 Uninterpreted_Data := Null_Address;
1468 pragma Assert (Open_Accepts /= null);
1470 Queuing.Select_Task_Entry_Call
1471 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1473 -- Determine the kind and disposition of the select
1475 Treatment := Default_Treatment (Select_Mode);
1476 Self_Id.Chosen_Index := No_Rendezvous;
1478 if Open_Alternative then
1479 if Entry_Call /= null then
1480 if Open_Accepts (Selection).Null_Body then
1481 Treatment := Accept_Alternative_Completed;
1483 else
1484 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1485 Treatment := Accept_Alternative_Selected;
1486 end if;
1488 Self_Id.Chosen_Index := Selection;
1490 elsif Treatment = No_Alternative_Open then
1491 Treatment := Accept_Alternative_Open;
1492 end if;
1493 end if;
1495 -- Handle the select according to the disposition selected above
1497 case Treatment is
1498 when Accept_Alternative_Selected =>
1500 -- Ready to rendezvous. In this case the accept body is not
1501 -- Null_Body. Defer abort until it gets into the accept body.
1503 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1504 Initialization.Defer_Abort_Nestable (Self_Id);
1505 STPO.Unlock (Self_Id);
1507 when Accept_Alternative_Completed =>
1509 -- Rendezvous is over
1511 if Parameters.Runtime_Traces then
1512 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1513 end if;
1515 STPO.Unlock (Self_Id);
1516 Caller := Entry_Call.Self;
1518 STPO.Write_Lock (Caller);
1519 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1520 STPO.Unlock (Caller);
1522 when Accept_Alternative_Open =>
1524 -- Wait for caller
1526 Self_Id.Open_Accepts := Open_Accepts;
1528 -- Wait for a normal call and a pending action until the
1529 -- Wakeup_Time is reached.
1531 Self_Id.Common.State := Acceptor_Delay_Sleep;
1533 -- Try to remove calls to Sleep in the loop below by letting the
1534 -- caller a chance of getting ready immediately, using Unlock
1535 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1537 if Single_Lock then
1538 Unlock_RTS;
1539 else
1540 Unlock (Self_Id);
1541 end if;
1543 if Self_Id.Open_Accepts /= null then
1544 Yield;
1545 end if;
1547 if Single_Lock then
1548 Lock_RTS;
1549 else
1550 Write_Lock (Self_Id);
1551 end if;
1553 -- Check if this task has been aborted while the lock was released
1555 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1556 Self_Id.Open_Accepts := null;
1557 end if;
1559 loop
1560 exit when Self_Id.Open_Accepts = null;
1562 if Timedout then
1563 Sleep (Self_Id, Acceptor_Delay_Sleep);
1564 else
1565 if Parameters.Runtime_Traces then
1566 Send_Trace_Info (WT_Select,
1567 Self_Id,
1568 Integer (Open_Accepts'Length),
1569 Timeout);
1570 end if;
1572 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1573 Acceptor_Delay_Sleep, Timedout, Yielded);
1574 end if;
1576 if Timedout then
1577 Self_Id.Open_Accepts := null;
1579 if Parameters.Runtime_Traces then
1580 Send_Trace_Info (E_Timeout);
1581 end if;
1582 end if;
1583 end loop;
1585 Self_Id.Common.State := Runnable;
1587 -- Self_Id.Common.Call should already be updated by the Caller if
1588 -- not aborted. It might also be ready to do rendezvous even if
1589 -- this wakes up due to an abort. Therefore, if the call is not
1590 -- empty we need to do the rendezvous if the accept body is not
1591 -- Null_Body.
1593 if Self_Id.Chosen_Index /= No_Rendezvous
1594 and then Self_Id.Common.Call /= null
1595 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1596 then
1597 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1599 pragma Assert (Self_Id.Deferral_Level = 1);
1601 Initialization.Defer_Abort_Nestable (Self_Id);
1603 -- Leave abort deferred until the accept body
1604 end if;
1606 STPO.Unlock (Self_Id);
1608 when No_Alternative_Open =>
1610 -- In this case, Index will be No_Rendezvous on return. We sleep
1611 -- for the time we need to.
1613 -- Wait for a signal or timeout. A wakeup can be made
1614 -- for several reasons:
1615 -- 1) Delay is expired
1616 -- 2) Pending_Action needs to be checked
1617 -- (Abort, Priority change)
1618 -- 3) Spurious wakeup
1620 Self_Id.Open_Accepts := null;
1621 Self_Id.Common.State := Acceptor_Delay_Sleep;
1623 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1624 Timedout, Yielded);
1626 Self_Id.Common.State := Runnable;
1628 STPO.Unlock (Self_Id);
1630 when others =>
1632 -- Should never get here
1634 pragma Assert (False);
1635 null;
1636 end case;
1638 if Single_Lock then
1639 Unlock_RTS;
1640 end if;
1642 if not Yielded then
1643 Yield;
1644 end if;
1646 -- Caller has been chosen
1648 -- Self_Id.Common.Call should already be updated by the Caller
1650 -- Self_Id.Chosen_Index should either be updated by the Caller
1651 -- or by Test_Selective_Wait
1653 Index := Self_Id.Chosen_Index;
1654 Initialization.Undefer_Abort_Nestable (Self_Id);
1656 -- Start rendezvous, if not already completed
1657 end Timed_Selective_Wait;
1659 ---------------------------
1660 -- Timed_Task_Entry_Call --
1661 ---------------------------
1663 procedure Timed_Task_Entry_Call
1664 (Acceptor : Task_Id;
1665 E : Task_Entry_Index;
1666 Uninterpreted_Data : System.Address;
1667 Timeout : Duration;
1668 Mode : Delay_Modes;
1669 Rendezvous_Successful : out Boolean)
1671 Self_Id : constant Task_Id := STPO.Self;
1672 Level : ATC_Level;
1673 Entry_Call : Entry_Call_Link;
1675 Yielded : Boolean;
1676 pragma Unreferenced (Yielded);
1678 begin
1679 -- If pragma Detect_Blocking is active then Program_Error must be
1680 -- raised if this potentially blocking operation is called from a
1681 -- protected action.
1683 if System.Tasking.Detect_Blocking
1684 and then Self_Id.Common.Protected_Action_Nesting > 0
1685 then
1686 raise Program_Error with "potentially blocking operation";
1687 end if;
1689 Initialization.Defer_Abort (Self_Id);
1690 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1692 pragma Debug
1693 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1694 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1696 if Parameters.Runtime_Traces then
1697 Send_Trace_Info (WT_Call, Acceptor,
1698 Entry_Index (E), Timeout);
1699 end if;
1701 Level := Self_Id.ATC_Nesting_Level;
1702 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1703 Entry_Call.Next := null;
1704 Entry_Call.Mode := Timed_Call;
1705 Entry_Call.Cancellation_Attempted := False;
1707 -- If this is a call made inside of an abort deferred region,
1708 -- the call should be never abortable.
1710 Entry_Call.State :=
1711 (if Self_Id.Deferral_Level > 1
1712 then Never_Abortable
1713 else Now_Abortable);
1715 Entry_Call.E := Entry_Index (E);
1716 Entry_Call.Prio := Get_Priority (Self_Id);
1717 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1718 Entry_Call.Called_Task := Acceptor;
1719 Entry_Call.Called_PO := Null_Address;
1720 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1721 Entry_Call.With_Abort := True;
1723 -- Note: the caller will undefer abort on return (see WARNING above)
1725 if Single_Lock then
1726 Lock_RTS;
1727 end if;
1729 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1730 STPO.Write_Lock (Self_Id);
1731 Utilities.Exit_One_ATC_Level (Self_Id);
1732 STPO.Unlock (Self_Id);
1734 if Single_Lock then
1735 Unlock_RTS;
1736 end if;
1738 Initialization.Undefer_Abort (Self_Id);
1740 if Parameters.Runtime_Traces then
1741 Send_Trace_Info (E_Missed, Acceptor);
1742 end if;
1743 raise Tasking_Error;
1744 end if;
1746 Write_Lock (Self_Id);
1747 Entry_Calls.Wait_For_Completion_With_Timeout
1748 (Entry_Call, Timeout, Mode, Yielded);
1749 Unlock (Self_Id);
1751 if Single_Lock then
1752 Unlock_RTS;
1753 end if;
1755 -- ??? Do we need to yield in case Yielded is False
1757 Rendezvous_Successful := Entry_Call.State = Done;
1758 Initialization.Undefer_Abort (Self_Id);
1759 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1760 end Timed_Task_Entry_Call;
1762 -------------------
1763 -- Wait_For_Call --
1764 -------------------
1766 procedure Wait_For_Call (Self_Id : Task_Id) is
1767 begin
1768 Self_Id.Common.State := Acceptor_Sleep;
1770 -- Try to remove calls to Sleep in the loop below by letting the caller
1771 -- a chance of getting ready immediately, using Unlock & Yield.
1772 -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
1774 if Single_Lock then
1775 Unlock_RTS;
1776 else
1777 Unlock (Self_Id);
1778 end if;
1780 if Self_Id.Open_Accepts /= null then
1781 Yield;
1782 end if;
1784 if Single_Lock then
1785 Lock_RTS;
1786 else
1787 Write_Lock (Self_Id);
1788 end if;
1790 -- Check if this task has been aborted while the lock was released
1792 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1793 Self_Id.Open_Accepts := null;
1794 end if;
1796 loop
1797 exit when Self_Id.Open_Accepts = null;
1798 Sleep (Self_Id, Acceptor_Sleep);
1799 end loop;
1801 Self_Id.Common.State := Runnable;
1802 end Wait_For_Call;
1804 end System.Tasking.Rendezvous;