File : s-tasren.adb
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-2014, 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 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Task_Primitives.Operations;
33 with System.Tasking.Entry_Calls;
34 with System.Tasking.Initialization;
35 with System.Tasking.Queuing;
36 with System.Tasking.Utilities;
37 with System.Tasking.Protected_Objects.Operations;
38 with System.Tasking.Debug;
39 with System.Restrictions;
40 with System.Parameters;
41 with System.Traces.Tasking;
42
43 package body System.Tasking.Rendezvous is
44
45 package STPO renames System.Task_Primitives.Operations;
46 package POO renames Protected_Objects.Operations;
47 package POE renames Protected_Objects.Entries;
48
49 use Parameters;
50 use Task_Primitives.Operations;
51 use System.Traces;
52 use System.Traces.Tasking;
53
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);
61
62 ----------------
63 -- Local Data --
64 ----------------
65
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);
71
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)
88 );
89
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
93
94 procedure Local_Defer_Abort (Self_Id : Task_Id) renames
95 System.Tasking.Initialization.Defer_Abort_Nestable;
96
97 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
98 System.Tasking.Initialization.Undefer_Abort_Nestable;
99
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.
109
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.
115
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
119
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.
129
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.
138
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.
145
146 -----------------
147 -- Accept_Call --
148 -----------------
149
150 procedure Accept_Call
151 (E : Task_Entry_Index;
152 Uninterpreted_Data : out System.Address)
153 is
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;
158
159 begin
160 Initialization.Defer_Abort (Self_Id);
161
162 if Single_Lock then
163 Lock_RTS;
164 end if;
165
166 STPO.Write_Lock (Self_Id);
167
168 if not Self_Id.Callable then
169 pragma Assert (Self_Id.Pending_ATC_Level = 0);
170
171 pragma Assert (Self_Id.Pending_Action);
172
173 STPO.Unlock (Self_Id);
174
175 if Single_Lock then
176 Unlock_RTS;
177 end if;
178
179 Initialization.Undefer_Abort (Self_Id);
180
181 -- Should never get here ???
182
183 pragma Assert (False);
184 raise Standard'Abort_Signal;
185 end if;
186
187 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
188
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;
193
194 else
195 -- Wait for a caller
196
197 Open_Accepts (1).Null_Body := False;
198 Open_Accepts (1).S := E;
199 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
200
201 -- Wait for normal call
202
203 if Parameters.Runtime_Traces then
204 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
205 end if;
206
207 pragma Debug
208 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
209 Wait_For_Call (Self_Id);
210
211 pragma Assert (Self_Id.Open_Accepts = null);
212
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
219
220 Uninterpreted_Data := System.Null_Address;
221 end if;
222 end if;
223
224 -- Self_Id.Common.Call should already be updated by the Caller. On
225 -- return, we will start the rendezvous.
226
227 STPO.Unlock (Self_Id);
228
229 if Single_Lock then
230 Unlock_RTS;
231 end if;
232
233 Initialization.Undefer_Abort (Self_Id);
234
235 if Parameters.Runtime_Traces then
236 Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
237 end if;
238 end Accept_Call;
239
240 --------------------
241 -- Accept_Trivial --
242 --------------------
243
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;
249
250 begin
251 Initialization.Defer_Abort_Nestable (Self_Id);
252
253 if Single_Lock then
254 Lock_RTS;
255 end if;
256
257 STPO.Write_Lock (Self_Id);
258
259 if not Self_Id.Callable then
260 pragma Assert (Self_Id.Pending_ATC_Level = 0);
261
262 pragma Assert (Self_Id.Pending_Action);
263
264 STPO.Unlock (Self_Id);
265
266 if Single_Lock then
267 Unlock_RTS;
268 end if;
269
270 Initialization.Undefer_Abort_Nestable (Self_Id);
271
272 -- Should never get here ???
273
274 pragma Assert (False);
275 raise Standard'Abort_Signal;
276 end if;
277
278 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
279
280 if Entry_Call = null then
281
282 -- Need to wait for entry call
283
284 Open_Accepts (1).Null_Body := True;
285 Open_Accepts (1).S := E;
286 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
287
288 if Parameters.Runtime_Traces then
289 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
290 end if;
291
292 pragma Debug
293 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
294
295 Wait_For_Call (Self_Id);
296
297 pragma Assert (Self_Id.Open_Accepts = null);
298
299 -- No need to do anything special here for pending abort.
300 -- Abort_Signal will be raised by Undefer on exit.
301
302 STPO.Unlock (Self_Id);
303
304 -- Found caller already waiting
305
306 else
307 pragma Assert (Entry_Call.State < Done);
308
309 STPO.Unlock (Self_Id);
310 Caller := Entry_Call.Self;
311
312 STPO.Write_Lock (Caller);
313 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
314 STPO.Unlock (Caller);
315 end if;
316
317 if Parameters.Runtime_Traces then
318 Send_Trace_Info (M_Accept_Complete);
319
320 -- Fake one, since there is (???) no way to know that the rendezvous
321 -- is over.
322
323 Send_Trace_Info (M_RDV_Complete);
324 end if;
325
326 if Single_Lock then
327 Unlock_RTS;
328 end if;
329
330 Initialization.Undefer_Abort_Nestable (Self_Id);
331 end Accept_Trivial;
332
333 --------------------
334 -- Boost_Priority --
335 --------------------
336
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;
349
350 -----------------
351 -- Call_Simple --
352 -----------------
353
354 procedure Call_Simple
355 (Acceptor : Task_Id;
356 E : Task_Entry_Index;
357 Uninterpreted_Data : System.Address)
358 is
359 Rendezvous_Successful : Boolean;
360 pragma Unreferenced (Rendezvous_Successful);
361
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.
366
367 if System.Tasking.Detect_Blocking
368 and then STPO.Self.Common.Protected_Action_Nesting > 0
369 then
370 raise Program_Error with
371 "potentially blocking operation";
372 end if;
373
374 Call_Synchronous
375 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
376 end Call_Simple;
377
378 ----------------------
379 -- Call_Synchronous --
380 ----------------------
381
382 procedure Call_Synchronous
383 (Acceptor : Task_Id;
384 E : Task_Entry_Index;
385 Uninterpreted_Data : System.Address;
386 Mode : Call_Modes;
387 Rendezvous_Successful : out Boolean)
388 is
389 Self_Id : constant Task_Id := STPO.Self;
390 Level : ATC_Level;
391 Entry_Call : Entry_Call_Link;
392
393 begin
394 pragma Assert (Mode /= Asynchronous_Call);
395
396 Local_Defer_Abort (Self_Id);
397 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
398 pragma Debug
399 (Debug.Trace (Self_Id, "CS: entered ATC level: " &
400 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
401 Level := Self_Id.ATC_Nesting_Level;
402 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
403 Entry_Call.Next := null;
404 Entry_Call.Mode := Mode;
405 Entry_Call.Cancellation_Attempted := False;
406
407 if Parameters.Runtime_Traces then
408 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
409 end if;
410
411 -- If this is a call made inside of an abort deferred region,
412 -- the call should be never abortable.
413
414 Entry_Call.State :=
415 (if Self_Id.Deferral_Level > 1
416 then Never_Abortable
417 else Now_Abortable);
418
419 Entry_Call.E := Entry_Index (E);
420 Entry_Call.Prio := Get_Priority (Self_Id);
421 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
422 Entry_Call.Called_Task := Acceptor;
423 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
424 Entry_Call.With_Abort := True;
425
426 -- Note: the caller will undefer abort on return (see WARNING above)
427
428 if Single_Lock then
429 Lock_RTS;
430 end if;
431
432 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
433 STPO.Write_Lock (Self_Id);
434 Utilities.Exit_One_ATC_Level (Self_Id);
435 STPO.Unlock (Self_Id);
436
437 if Single_Lock then
438 Unlock_RTS;
439 end if;
440
441 if Parameters.Runtime_Traces then
442 Send_Trace_Info (E_Missed, Acceptor);
443 end if;
444
445 Local_Undefer_Abort (Self_Id);
446 raise Tasking_Error;
447 end if;
448
449 STPO.Write_Lock (Self_Id);
450 pragma Debug
451 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
452 Entry_Calls.Wait_For_Completion (Entry_Call);
453 pragma Debug
454 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
455 Rendezvous_Successful := Entry_Call.State = Done;
456 STPO.Unlock (Self_Id);
457
458 if Single_Lock then
459 Unlock_RTS;
460 end if;
461
462 Local_Undefer_Abort (Self_Id);
463 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
464 end Call_Synchronous;
465
466 --------------
467 -- Callable --
468 --------------
469
470 function Callable (T : Task_Id) return Boolean is
471 Result : Boolean;
472 Self_Id : constant Task_Id := STPO.Self;
473
474 begin
475 Initialization.Defer_Abort_Nestable (Self_Id);
476
477 if Single_Lock then
478 Lock_RTS;
479 end if;
480
481 STPO.Write_Lock (T);
482 Result := T.Callable;
483 STPO.Unlock (T);
484
485 if Single_Lock then
486 Unlock_RTS;
487 end if;
488
489 Initialization.Undefer_Abort_Nestable (Self_Id);
490 return Result;
491 end Callable;
492
493 ----------------------------
494 -- Cancel_Task_Entry_Call --
495 ----------------------------
496
497 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
498 begin
499 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
500 end Cancel_Task_Entry_Call;
501
502 -------------------------
503 -- Complete_Rendezvous --
504 -------------------------
505
506 procedure Complete_Rendezvous is
507 begin
508 Local_Complete_Rendezvous (Ada.Exceptions.Null_Id);
509 end Complete_Rendezvous;
510
511 -------------------------------------
512 -- Exceptional_Complete_Rendezvous --
513 -------------------------------------
514
515 procedure Exceptional_Complete_Rendezvous
516 (Ex : Ada.Exceptions.Exception_Id)
517 is
518 procedure Internal_Reraise;
519 pragma No_Return (Internal_Reraise);
520 pragma Import (C, Internal_Reraise, "__gnat_reraise");
521
522 begin
523 Local_Complete_Rendezvous (Ex);
524 Internal_Reraise;
525
526 -- ??? Do we need to give precedence to Program_Error that might be
527 -- raised due to failure of finalization, over Tasking_Error from
528 -- failure of requeue?
529 end Exceptional_Complete_Rendezvous;
530
531 -------------------------------
532 -- Local_Complete_Rendezvous --
533 -------------------------------
534
535 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is
536 Self_Id : constant Task_Id := STPO.Self;
537 Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
538 Caller : Task_Id;
539 Called_PO : STPE.Protection_Entries_Access;
540 Acceptor_Prev_Priority : Integer;
541
542 Ceiling_Violation : Boolean;
543
544 use type Ada.Exceptions.Exception_Id;
545 procedure Transfer_Occurrence
546 (Target : Ada.Exceptions.Exception_Occurrence_Access;
547 Source : Ada.Exceptions.Exception_Occurrence);
548 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
549
550 use type STPE.Protection_Entries_Access;
551
552 begin
553 -- The deferral level is critical here, since we want to raise an
554 -- exception or allow abort to take place, if there is an exception or
555 -- abort pending.
556
557 pragma Debug
558 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
559
560 if Ex = Ada.Exceptions.Null_Id then
561
562 -- The call came from normal end-of-rendezvous, so abort is not yet
563 -- deferred.
564
565 if Parameters.Runtime_Traces then
566 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
567 end if;
568
569 Initialization.Defer_Abort (Self_Id);
570
571 elsif ZCX_By_Default then
572
573 -- With ZCX, aborts are not automatically deferred in handlers
574
575 Initialization.Defer_Abort (Self_Id);
576 end if;
577
578 -- We need to clean up any accepts which Self may have been serving when
579 -- it was aborted.
580
581 if Ex = Standard'Abort_Signal'Identity then
582 if Single_Lock then
583 Lock_RTS;
584 end if;
585
586 while Entry_Call /= null loop
587 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
588
589 -- All forms of accept make sure that the acceptor is not
590 -- completed, before accepting further calls, so that we
591 -- can be sure that no further calls are made after the
592 -- current calls are purged.
593
594 Caller := Entry_Call.Self;
595
596 -- Take write lock. This follows the lock precedence rule that
597 -- Caller may be locked while holding lock of Acceptor. Complete
598 -- the call abnormally, with exception.
599
600 STPO.Write_Lock (Caller);
601 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
602 STPO.Unlock (Caller);
603 Entry_Call := Entry_Call.Acceptor_Prev_Call;
604 end loop;
605
606 if Single_Lock then
607 Unlock_RTS;
608 end if;
609
610 else
611 Caller := Entry_Call.Self;
612
613 if Entry_Call.Needs_Requeue then
614
615 -- We dare not lock Self_Id at the same time as Caller, for fear
616 -- of deadlock.
617
618 Entry_Call.Needs_Requeue := False;
619 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
620
621 if Entry_Call.Called_Task /= null then
622
623 -- Requeue to another task entry
624
625 if Single_Lock then
626 Lock_RTS;
627 end if;
628
629 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
630 if Single_Lock then
631 Unlock_RTS;
632 end if;
633
634 Initialization.Undefer_Abort (Self_Id);
635 raise Tasking_Error;
636 end if;
637
638 if Single_Lock then
639 Unlock_RTS;
640 end if;
641
642 else
643 -- Requeue to a protected entry
644
645 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
646 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
647
648 if Ceiling_Violation then
649 pragma Assert (Ex = Ada.Exceptions.Null_Id);
650 Entry_Call.Exception_To_Raise := Program_Error'Identity;
651
652 if Single_Lock then
653 Lock_RTS;
654 end if;
655
656 STPO.Write_Lock (Caller);
657 Initialization.Wakeup_Entry_Caller
658 (Self_Id, Entry_Call, Done);
659 STPO.Unlock (Caller);
660
661 if Single_Lock then
662 Unlock_RTS;
663 end if;
664
665 else
666 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
667 POO.PO_Service_Entries (Self_Id, Called_PO);
668 end if;
669 end if;
670
671 Entry_Calls.Reset_Priority
672 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
673
674 else
675 -- The call does not need to be requeued
676
677 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
678 Entry_Call.Exception_To_Raise := Ex;
679
680 if Single_Lock then
681 Lock_RTS;
682 end if;
683
684 STPO.Write_Lock (Caller);
685
686 -- Done with Caller locked to make sure that Wakeup is not lost
687
688 if Ex /= Ada.Exceptions.Null_Id then
689 Transfer_Occurrence
690 (Caller.Common.Compiler_Data.Current_Excep'Access,
691 Self_Id.Common.Compiler_Data.Current_Excep);
692 end if;
693
694 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
695 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
696
697 STPO.Unlock (Caller);
698
699 if Single_Lock then
700 Unlock_RTS;
701 end if;
702
703 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
704 end if;
705 end if;
706
707 Initialization.Undefer_Abort (Self_Id);
708 end Local_Complete_Rendezvous;
709
710 -------------------------------------
711 -- Requeue_Protected_To_Task_Entry --
712 -------------------------------------
713
714 procedure Requeue_Protected_To_Task_Entry
715 (Object : STPE.Protection_Entries_Access;
716 Acceptor : Task_Id;
717 E : Task_Entry_Index;
718 With_Abort : Boolean)
719 is
720 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
721 begin
722 pragma Assert (STPO.Self.Deferral_Level > 0);
723
724 Entry_Call.E := Entry_Index (E);
725 Entry_Call.Called_Task := Acceptor;
726 Entry_Call.Called_PO := Null_Address;
727 Entry_Call.With_Abort := With_Abort;
728 Object.Call_In_Progress := null;
729 end Requeue_Protected_To_Task_Entry;
730
731 ------------------------
732 -- Requeue_Task_Entry --
733 ------------------------
734
735 procedure Requeue_Task_Entry
736 (Acceptor : Task_Id;
737 E : Task_Entry_Index;
738 With_Abort : Boolean)
739 is
740 Self_Id : constant Task_Id := STPO.Self;
741 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
742 begin
743 Initialization.Defer_Abort (Self_Id);
744 Entry_Call.Needs_Requeue := True;
745 Entry_Call.With_Abort := With_Abort;
746 Entry_Call.E := Entry_Index (E);
747 Entry_Call.Called_Task := Acceptor;
748 Initialization.Undefer_Abort (Self_Id);
749 end Requeue_Task_Entry;
750
751 --------------------
752 -- Selective_Wait --
753 --------------------
754
755 procedure Selective_Wait
756 (Open_Accepts : Accept_List_Access;
757 Select_Mode : Select_Modes;
758 Uninterpreted_Data : out System.Address;
759 Index : out Select_Index)
760 is
761 Self_Id : constant Task_Id := STPO.Self;
762 Entry_Call : Entry_Call_Link;
763 Treatment : Select_Treatment;
764 Caller : Task_Id;
765 Selection : Select_Index;
766 Open_Alternative : Boolean;
767
768 begin
769 Initialization.Defer_Abort (Self_Id);
770
771 if Single_Lock then
772 Lock_RTS;
773 end if;
774
775 STPO.Write_Lock (Self_Id);
776
777 if not Self_Id.Callable then
778 pragma Assert (Self_Id.Pending_ATC_Level = 0);
779
780 pragma Assert (Self_Id.Pending_Action);
781
782 STPO.Unlock (Self_Id);
783
784 if Single_Lock then
785 Unlock_RTS;
786 end if;
787
788 -- ??? In some cases abort is deferred more than once. Need to
789 -- figure out why this happens.
790
791 if Self_Id.Deferral_Level > 1 then
792 Self_Id.Deferral_Level := 1;
793 end if;
794
795 Initialization.Undefer_Abort (Self_Id);
796
797 -- Should never get here ???
798
799 pragma Assert (False);
800 raise Standard'Abort_Signal;
801 end if;
802
803 pragma Assert (Open_Accepts /= null);
804
805 Uninterpreted_Data := Null_Address;
806
807 Queuing.Select_Task_Entry_Call
808 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
809
810 -- Determine the kind and disposition of the select
811
812 Treatment := Default_Treatment (Select_Mode);
813 Self_Id.Chosen_Index := No_Rendezvous;
814
815 if Open_Alternative then
816 if Entry_Call /= null then
817 if Open_Accepts (Selection).Null_Body then
818 Treatment := Accept_Alternative_Completed;
819 else
820 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
821 Treatment := Accept_Alternative_Selected;
822 end if;
823
824 Self_Id.Chosen_Index := Selection;
825
826 elsif Treatment = No_Alternative_Open then
827 Treatment := Accept_Alternative_Open;
828 end if;
829 end if;
830
831 -- Handle the select according to the disposition selected above
832
833 case Treatment is
834 when Accept_Alternative_Selected =>
835
836 -- Ready to rendezvous
837
838 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
839
840 -- In this case the accept body is not Null_Body. Defer abort
841 -- until it gets into the accept body. The compiler has inserted
842 -- a call to Abort_Undefer as part of the entry expansion.
843
844 pragma Assert (Self_Id.Deferral_Level = 1);
845
846 Initialization.Defer_Abort_Nestable (Self_Id);
847 STPO.Unlock (Self_Id);
848
849 when Accept_Alternative_Completed =>
850
851 -- Accept body is null, so rendezvous is over immediately
852
853 if Parameters.Runtime_Traces then
854 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
855 end if;
856
857 STPO.Unlock (Self_Id);
858 Caller := Entry_Call.Self;
859
860 STPO.Write_Lock (Caller);
861 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
862 STPO.Unlock (Caller);
863
864 when Accept_Alternative_Open =>
865
866 -- Wait for caller
867
868 Self_Id.Open_Accepts := Open_Accepts;
869 pragma Debug
870 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
871
872 if Parameters.Runtime_Traces then
873 Send_Trace_Info (W_Select, Self_Id,
874 Integer (Open_Accepts'Length));
875 end if;
876
877 Wait_For_Call (Self_Id);
878
879 pragma Assert (Self_Id.Open_Accepts = null);
880
881 -- Self_Id.Common.Call should already be updated by the Caller if
882 -- not aborted. It might also be ready to do rendezvous even if
883 -- this wakes up due to an abort. Therefore, if the call is not
884 -- empty we need to do the rendezvous if the accept body is not
885 -- Null_Body.
886
887 -- Aren't the first two conditions below redundant???
888
889 if Self_Id.Chosen_Index /= No_Rendezvous
890 and then Self_Id.Common.Call /= null
891 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
892 then
893 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
894
895 pragma Assert
896 (Self_Id.Deferral_Level = 1
897 or else
898 (Self_Id.Deferral_Level = 0
899 and then not Restrictions.Abort_Allowed));
900
901 Initialization.Defer_Abort_Nestable (Self_Id);
902
903 -- Leave abort deferred until the accept body
904 -- The compiler has inserted a call to Abort_Undefer as part of
905 -- the entry expansion.
906 end if;
907
908 STPO.Unlock (Self_Id);
909
910 when Else_Selected =>
911 pragma Assert (Self_Id.Open_Accepts = null);
912
913 if Parameters.Runtime_Traces then
914 Send_Trace_Info (M_Select_Else);
915 end if;
916
917 STPO.Unlock (Self_Id);
918
919 when Terminate_Selected =>
920
921 -- Terminate alternative is open
922
923 Self_Id.Open_Accepts := Open_Accepts;
924 Self_Id.Common.State := Acceptor_Sleep;
925
926 -- Notify ancestors that this task is on a terminate alternative
927
928 STPO.Unlock (Self_Id);
929 Utilities.Make_Passive (Self_Id, Task_Completed => False);
930 STPO.Write_Lock (Self_Id);
931
932 -- Wait for normal entry call or termination
933
934 Wait_For_Call (Self_Id);
935
936 pragma Assert (Self_Id.Open_Accepts = null);
937
938 if Self_Id.Terminate_Alternative then
939
940 -- An entry call should have reset this to False, so we must be
941 -- aborted. We cannot be in an async. select, since that is not
942 -- legal, so the abort must be of the entire task. Therefore,
943 -- we do not need to cancel the terminate alternative. The
944 -- cleanup will be done in Complete_Master.
945
946 pragma Assert (Self_Id.Pending_ATC_Level = 0);
947 pragma Assert (Self_Id.Awake_Count = 0);
948
949 STPO.Unlock (Self_Id);
950
951 if Single_Lock then
952 Unlock_RTS;
953 end if;
954
955 Index := Self_Id.Chosen_Index;
956 Initialization.Undefer_Abort_Nestable (Self_Id);
957
958 if Self_Id.Pending_Action then
959 Initialization.Do_Pending_Action (Self_Id);
960 end if;
961
962 return;
963
964 else
965 -- Self_Id.Common.Call and Self_Id.Chosen_Index
966 -- should already be updated by the Caller.
967
968 if Self_Id.Chosen_Index /= No_Rendezvous
969 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
970 then
971 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
972
973 pragma Assert (Self_Id.Deferral_Level = 1);
974
975 -- We need an extra defer here, to keep abort
976 -- deferred until we get into the accept body
977 -- The compiler has inserted a call to Abort_Undefer as part
978 -- of the entry expansion.
979
980 Initialization.Defer_Abort_Nestable (Self_Id);
981 end if;
982 end if;
983
984 STPO.Unlock (Self_Id);
985
986 when No_Alternative_Open =>
987
988 -- In this case, Index will be No_Rendezvous on return, which
989 -- should cause a Program_Error if it is not a Delay_Mode.
990
991 -- If delay alternative exists (Delay_Mode) we should suspend
992 -- until the delay expires.
993
994 Self_Id.Open_Accepts := null;
995
996 if Select_Mode = Delay_Mode then
997 Self_Id.Common.State := Delay_Sleep;
998
999 loop
1000 exit when
1001 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1002 Sleep (Self_Id, Delay_Sleep);
1003 end loop;
1004
1005 Self_Id.Common.State := Runnable;
1006 STPO.Unlock (Self_Id);
1007
1008 else
1009 STPO.Unlock (Self_Id);
1010
1011 if Single_Lock then
1012 Unlock_RTS;
1013 end if;
1014
1015 Initialization.Undefer_Abort (Self_Id);
1016 raise Program_Error with
1017 "entry call not a delay mode";
1018 end if;
1019 end case;
1020
1021 if Single_Lock then
1022 Unlock_RTS;
1023 end if;
1024
1025 -- Caller has been chosen
1026
1027 -- Self_Id.Common.Call should already be updated by the Caller.
1028
1029 -- Self_Id.Chosen_Index should either be updated by the Caller
1030 -- or by Test_Selective_Wait.
1031
1032 -- On return, we sill start rendezvous unless the accept body is
1033 -- null. In the latter case, we will have already completed the RV.
1034
1035 Index := Self_Id.Chosen_Index;
1036 Initialization.Undefer_Abort_Nestable (Self_Id);
1037 end Selective_Wait;
1038
1039 ------------------------------------
1040 -- Setup_For_Rendezvous_With_Body --
1041 ------------------------------------
1042
1043 procedure Setup_For_Rendezvous_With_Body
1044 (Entry_Call : Entry_Call_Link;
1045 Acceptor : Task_Id) is
1046 begin
1047 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1048 Acceptor.Common.Call := Entry_Call;
1049
1050 if Entry_Call.State = Now_Abortable then
1051 Entry_Call.State := Was_Abortable;
1052 end if;
1053
1054 Boost_Priority (Entry_Call, Acceptor);
1055 end Setup_For_Rendezvous_With_Body;
1056
1057 ----------------
1058 -- Task_Count --
1059 ----------------
1060
1061 function Task_Count (E : Task_Entry_Index) return Natural is
1062 Self_Id : constant Task_Id := STPO.Self;
1063 Return_Count : Natural;
1064
1065 begin
1066 Initialization.Defer_Abort (Self_Id);
1067
1068 if Single_Lock then
1069 Lock_RTS;
1070 end if;
1071
1072 STPO.Write_Lock (Self_Id);
1073 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1074 STPO.Unlock (Self_Id);
1075
1076 if Single_Lock then
1077 Unlock_RTS;
1078 end if;
1079
1080 Initialization.Undefer_Abort (Self_Id);
1081
1082 return Return_Count;
1083 end Task_Count;
1084
1085 ----------------------
1086 -- Task_Do_Or_Queue --
1087 ----------------------
1088
1089 function Task_Do_Or_Queue
1090 (Self_ID : Task_Id;
1091 Entry_Call : Entry_Call_Link) return Boolean
1092 is
1093 E : constant Task_Entry_Index :=
1094 Task_Entry_Index (Entry_Call.E);
1095 Old_State : constant Entry_Call_State := Entry_Call.State;
1096 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1097 Parent : constant Task_Id := Acceptor.Common.Parent;
1098 Null_Body : Boolean;
1099
1100 begin
1101 -- Find out whether Entry_Call can be accepted immediately
1102
1103 -- If the Acceptor is not callable, return False.
1104 -- If the rendezvous can start, initiate it.
1105 -- If the accept-body is trivial, also complete the rendezvous.
1106 -- If the acceptor is not ready, enqueue the call.
1107
1108 -- This should have a special case for Accept_Call and Accept_Trivial,
1109 -- so that we don't have the loop setup overhead, below.
1110
1111 -- The call state Done is used here and elsewhere to include both the
1112 -- case of normal successful completion, and the case of an exception
1113 -- being raised. The difference is that if an exception is raised no one
1114 -- will pay attention to the fact that State = Done. Instead the
1115 -- exception will be raised in Undefer_Abort, and control will skip past
1116 -- the place where we normally would resume from an entry call.
1117
1118 pragma Assert (not Queuing.Onqueue (Entry_Call));
1119
1120 -- We rely that the call is off-queue for protection, that the caller
1121 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1122 -- record for another call. We rely on the Caller's lock for call State
1123 -- mod's.
1124
1125 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1126 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1127 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor
1128 -- is locked. Therefore, we need to lock both. Attempts to avoid locking
1129 -- Parent tend to result in race conditions. It would work to unlock
1130 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be
1131 -- False, but that violates the rule of properly nested locking (see
1132 -- System.Tasking).
1133
1134 STPO.Write_Lock (Parent);
1135 STPO.Write_Lock (Acceptor);
1136
1137 -- If the acceptor is not callable, abort the call and return False
1138
1139 if not Acceptor.Callable then
1140 STPO.Unlock (Acceptor);
1141 STPO.Unlock (Parent);
1142
1143 pragma Assert (Entry_Call.State < Done);
1144
1145 -- In case we are not the caller, set up the caller
1146 -- to raise Tasking_Error when it wakes up.
1147
1148 STPO.Write_Lock (Entry_Call.Self);
1149 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1150 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1151 STPO.Unlock (Entry_Call.Self);
1152
1153 return False;
1154 end if;
1155
1156 -- Try to serve the call immediately
1157
1158 if Acceptor.Open_Accepts /= null then
1159 for J in Acceptor.Open_Accepts'Range loop
1160 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1161
1162 -- Commit acceptor to rendezvous with us
1163
1164 Acceptor.Chosen_Index := J;
1165 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1166 Acceptor.Open_Accepts := null;
1167
1168 -- Prevent abort while call is being served
1169
1170 if Entry_Call.State = Now_Abortable then
1171 Entry_Call.State := Was_Abortable;
1172 end if;
1173
1174 if Acceptor.Terminate_Alternative then
1175
1176 -- Cancel terminate alternative. See matching code in
1177 -- Selective_Wait and Vulnerable_Complete_Master.
1178
1179 Acceptor.Terminate_Alternative := False;
1180 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1181
1182 if Acceptor.Awake_Count = 1 then
1183
1184 -- Notify parent that acceptor is awake
1185
1186 pragma Assert (Parent.Awake_Count > 0);
1187
1188 Parent.Awake_Count := Parent.Awake_Count + 1;
1189
1190 if Parent.Common.State = Master_Completion_Sleep
1191 and then Acceptor.Master_of_Task = Parent.Master_Within
1192 then
1193 Parent.Common.Wait_Count :=
1194 Parent.Common.Wait_Count + 1;
1195 end if;
1196 end if;
1197 end if;
1198
1199 if Null_Body then
1200
1201 -- Rendezvous is over immediately
1202
1203 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1204 STPO.Unlock (Acceptor);
1205 STPO.Unlock (Parent);
1206
1207 STPO.Write_Lock (Entry_Call.Self);
1208 Initialization.Wakeup_Entry_Caller
1209 (Self_ID, Entry_Call, Done);
1210 STPO.Unlock (Entry_Call.Self);
1211
1212 else
1213 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1214
1215 -- For terminate_alternative, acceptor may not be asleep
1216 -- yet, so we skip the wakeup
1217
1218 if Acceptor.Common.State /= Runnable then
1219 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1220 end if;
1221
1222 STPO.Unlock (Acceptor);
1223 STPO.Unlock (Parent);
1224 end if;
1225
1226 return True;
1227 end if;
1228 end loop;
1229
1230 -- The acceptor is accepting, but not this entry
1231 end if;
1232
1233 -- If the acceptor was ready to accept this call,
1234 -- we would not have gotten this far, so now we should
1235 -- (re)enqueue the call, if the mode permits that.
1236
1237 -- If the call is timed, it may have timed out before the requeue,
1238 -- in the unusual case where the current accept has taken longer than
1239 -- the given delay. In that case the requeue is cancelled, and the
1240 -- outer timed call will be aborted.
1241
1242 if Entry_Call.Mode = Conditional_Call
1243 or else
1244 (Entry_Call.Mode = Timed_Call
1245 and then Entry_Call.With_Abort
1246 and then Entry_Call.Cancellation_Attempted)
1247 then
1248 STPO.Unlock (Acceptor);
1249 STPO.Unlock (Parent);
1250
1251 STPO.Write_Lock (Entry_Call.Self);
1252
1253 pragma Assert (Entry_Call.State >= Was_Abortable);
1254
1255 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1256 STPO.Unlock (Entry_Call.Self);
1257
1258 else
1259 -- Timed_Call, Simple_Call, or Asynchronous_Call
1260
1261 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1262
1263 -- Update abortability of call
1264
1265 pragma Assert (Old_State < Done);
1266
1267 Entry_Call.State :=
1268 New_State (Entry_Call.With_Abort, Entry_Call.State);
1269
1270 STPO.Unlock (Acceptor);
1271 STPO.Unlock (Parent);
1272
1273 if Old_State /= Entry_Call.State
1274 and then Entry_Call.State = Now_Abortable
1275 and then Entry_Call.Mode /= Simple_Call
1276 and then Entry_Call.Self /= Self_ID
1277
1278 -- Asynchronous_Call or Conditional_Call
1279
1280 then
1281 -- Because of ATCB lock ordering rule
1282
1283 STPO.Write_Lock (Entry_Call.Self);
1284
1285 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1286
1287 -- Caller may not yet have reached wait-point
1288
1289 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1290 end if;
1291
1292 STPO.Unlock (Entry_Call.Self);
1293 end if;
1294 end if;
1295
1296 return True;
1297 end Task_Do_Or_Queue;
1298
1299 ---------------------
1300 -- Task_Entry_Call --
1301 ---------------------
1302
1303 procedure Task_Entry_Call
1304 (Acceptor : Task_Id;
1305 E : Task_Entry_Index;
1306 Uninterpreted_Data : System.Address;
1307 Mode : Call_Modes;
1308 Rendezvous_Successful : out Boolean)
1309 is
1310 Self_Id : constant Task_Id := STPO.Self;
1311 Entry_Call : Entry_Call_Link;
1312
1313 begin
1314 -- If pragma Detect_Blocking is active then Program_Error must be
1315 -- raised if this potentially blocking operation is called from a
1316 -- protected action.
1317
1318 if System.Tasking.Detect_Blocking
1319 and then Self_Id.Common.Protected_Action_Nesting > 0
1320 then
1321 raise Program_Error with
1322 "potentially blocking operation";
1323 end if;
1324
1325 if Parameters.Runtime_Traces then
1326 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1327 end if;
1328
1329 if Mode = Simple_Call or else Mode = Conditional_Call then
1330 Call_Synchronous
1331 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1332
1333 else
1334 -- This is an asynchronous call
1335
1336 -- Abort must already be deferred by the compiler-generated code.
1337 -- Without this, an abort that occurs between the time that this
1338 -- call is made and the time that the abortable part's cleanup
1339 -- handler is set up might miss the cleanup handler and leave the
1340 -- call pending.
1341
1342 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1343 pragma Debug
1344 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1345 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1346 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1347 Entry_Call.Next := null;
1348 Entry_Call.Mode := Mode;
1349 Entry_Call.Cancellation_Attempted := False;
1350 Entry_Call.State := Not_Yet_Abortable;
1351 Entry_Call.E := Entry_Index (E);
1352 Entry_Call.Prio := Get_Priority (Self_Id);
1353 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1354 Entry_Call.Called_Task := Acceptor;
1355 Entry_Call.Called_PO := Null_Address;
1356 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1357 Entry_Call.With_Abort := True;
1358
1359 if Single_Lock then
1360 Lock_RTS;
1361 end if;
1362
1363 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1364 STPO.Write_Lock (Self_Id);
1365 Utilities.Exit_One_ATC_Level (Self_Id);
1366 STPO.Unlock (Self_Id);
1367
1368 if Single_Lock then
1369 Unlock_RTS;
1370 end if;
1371
1372 Initialization.Undefer_Abort (Self_Id);
1373
1374 if Parameters.Runtime_Traces then
1375 Send_Trace_Info (E_Missed, Acceptor);
1376 end if;
1377
1378 raise Tasking_Error;
1379 end if;
1380
1381 -- The following is special for async. entry calls. If the call was
1382 -- not queued abortably, we need to wait until it is before
1383 -- proceeding with the abortable part.
1384
1385 -- Wait_Until_Abortable can be called unconditionally here, but it is
1386 -- expensive.
1387
1388 if Entry_Call.State < Was_Abortable then
1389 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1390 end if;
1391
1392 if Single_Lock then
1393 Unlock_RTS;
1394 end if;
1395
1396 -- Note: following assignment needs to be atomic
1397
1398 Rendezvous_Successful := Entry_Call.State = Done;
1399 end if;
1400 end Task_Entry_Call;
1401
1402 -----------------------
1403 -- Task_Entry_Caller --
1404 -----------------------
1405
1406 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1407 Self_Id : constant Task_Id := STPO.Self;
1408 Entry_Call : Entry_Call_Link;
1409
1410 begin
1411 Entry_Call := Self_Id.Common.Call;
1412
1413 for Depth in 1 .. D loop
1414 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1415 pragma Assert (Entry_Call /= null);
1416 end loop;
1417
1418 return Entry_Call.Self;
1419 end Task_Entry_Caller;
1420
1421 --------------------------
1422 -- Timed_Selective_Wait --
1423 --------------------------
1424
1425 procedure Timed_Selective_Wait
1426 (Open_Accepts : Accept_List_Access;
1427 Select_Mode : Select_Modes;
1428 Uninterpreted_Data : out System.Address;
1429 Timeout : Duration;
1430 Mode : Delay_Modes;
1431 Index : out Select_Index)
1432 is
1433 Self_Id : constant Task_Id := STPO.Self;
1434 Treatment : Select_Treatment;
1435 Entry_Call : Entry_Call_Link;
1436 Caller : Task_Id;
1437 Selection : Select_Index;
1438 Open_Alternative : Boolean;
1439 Timedout : Boolean := False;
1440 Yielded : Boolean := True;
1441
1442 begin
1443 pragma Assert (Select_Mode = Delay_Mode);
1444
1445 Initialization.Defer_Abort (Self_Id);
1446
1447 -- If we are aborted here, the effect will be pending
1448
1449 if Single_Lock then
1450 Lock_RTS;
1451 end if;
1452
1453 STPO.Write_Lock (Self_Id);
1454
1455 if not Self_Id.Callable then
1456 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1457
1458 pragma Assert (Self_Id.Pending_Action);
1459
1460 STPO.Unlock (Self_Id);
1461
1462 if Single_Lock then
1463 Unlock_RTS;
1464 end if;
1465
1466 Initialization.Undefer_Abort (Self_Id);
1467
1468 -- Should never get here ???
1469
1470 pragma Assert (False);
1471 raise Standard'Abort_Signal;
1472 end if;
1473
1474 Uninterpreted_Data := Null_Address;
1475
1476 pragma Assert (Open_Accepts /= null);
1477
1478 Queuing.Select_Task_Entry_Call
1479 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1480
1481 -- Determine the kind and disposition of the select
1482
1483 Treatment := Default_Treatment (Select_Mode);
1484 Self_Id.Chosen_Index := No_Rendezvous;
1485
1486 if Open_Alternative then
1487 if Entry_Call /= null then
1488 if Open_Accepts (Selection).Null_Body then
1489 Treatment := Accept_Alternative_Completed;
1490
1491 else
1492 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1493 Treatment := Accept_Alternative_Selected;
1494 end if;
1495
1496 Self_Id.Chosen_Index := Selection;
1497
1498 elsif Treatment = No_Alternative_Open then
1499 Treatment := Accept_Alternative_Open;
1500 end if;
1501 end if;
1502
1503 -- Handle the select according to the disposition selected above
1504
1505 case Treatment is
1506 when Accept_Alternative_Selected =>
1507
1508 -- Ready to rendezvous. In this case the accept body is not
1509 -- Null_Body. Defer abort until it gets into the accept body.
1510
1511 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1512 Initialization.Defer_Abort_Nestable (Self_Id);
1513 STPO.Unlock (Self_Id);
1514
1515 when Accept_Alternative_Completed =>
1516
1517 -- Rendezvous is over
1518
1519 if Parameters.Runtime_Traces then
1520 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1521 end if;
1522
1523 STPO.Unlock (Self_Id);
1524 Caller := Entry_Call.Self;
1525
1526 STPO.Write_Lock (Caller);
1527 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1528 STPO.Unlock (Caller);
1529
1530 when Accept_Alternative_Open =>
1531
1532 -- Wait for caller
1533
1534 Self_Id.Open_Accepts := Open_Accepts;
1535
1536 -- Wait for a normal call and a pending action until the
1537 -- Wakeup_Time is reached.
1538
1539 Self_Id.Common.State := Acceptor_Delay_Sleep;
1540
1541 -- Try to remove calls to Sleep in the loop below by letting the
1542 -- caller a chance of getting ready immediately, using Unlock
1543 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1544
1545 if Single_Lock then
1546 Unlock_RTS;
1547 else
1548 Unlock (Self_Id);
1549 end if;
1550
1551 if Self_Id.Open_Accepts /= null then
1552 Yield;
1553 end if;
1554
1555 if Single_Lock then
1556 Lock_RTS;
1557 else
1558 Write_Lock (Self_Id);
1559 end if;
1560
1561 -- Check if this task has been aborted while the lock was released
1562
1563 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1564 Self_Id.Open_Accepts := null;
1565 end if;
1566
1567 loop
1568 exit when Self_Id.Open_Accepts = null;
1569
1570 if Timedout then
1571 Sleep (Self_Id, Acceptor_Delay_Sleep);
1572 else
1573 if Parameters.Runtime_Traces then
1574 Send_Trace_Info (WT_Select,
1575 Self_Id,
1576 Integer (Open_Accepts'Length),
1577 Timeout);
1578 end if;
1579
1580 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1581 Acceptor_Delay_Sleep, Timedout, Yielded);
1582 end if;
1583
1584 if Timedout then
1585 Self_Id.Open_Accepts := null;
1586
1587 if Parameters.Runtime_Traces then
1588 Send_Trace_Info (E_Timeout);
1589 end if;
1590 end if;
1591 end loop;
1592
1593 Self_Id.Common.State := Runnable;
1594
1595 -- Self_Id.Common.Call should already be updated by the Caller if
1596 -- not aborted. It might also be ready to do rendezvous even if
1597 -- this wakes up due to an abort. Therefore, if the call is not
1598 -- empty we need to do the rendezvous if the accept body is not
1599 -- Null_Body.
1600
1601 if Self_Id.Chosen_Index /= No_Rendezvous
1602 and then Self_Id.Common.Call /= null
1603 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1604 then
1605 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1606
1607 pragma Assert (Self_Id.Deferral_Level = 1);
1608
1609 Initialization.Defer_Abort_Nestable (Self_Id);
1610
1611 -- Leave abort deferred until the accept body
1612 end if;
1613
1614 STPO.Unlock (Self_Id);
1615
1616 when No_Alternative_Open =>
1617
1618 -- In this case, Index will be No_Rendezvous on return. We sleep
1619 -- for the time we need to.
1620
1621 -- Wait for a signal or timeout. A wakeup can be made
1622 -- for several reasons:
1623 -- 1) Delay is expired
1624 -- 2) Pending_Action needs to be checked
1625 -- (Abort, Priority change)
1626 -- 3) Spurious wakeup
1627
1628 Self_Id.Open_Accepts := null;
1629 Self_Id.Common.State := Acceptor_Delay_Sleep;
1630
1631 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1632 Timedout, Yielded);
1633
1634 Self_Id.Common.State := Runnable;
1635
1636 STPO.Unlock (Self_Id);
1637
1638 when others =>
1639
1640 -- Should never get here
1641
1642 pragma Assert (False);
1643 null;
1644 end case;
1645
1646 if Single_Lock then
1647 Unlock_RTS;
1648 end if;
1649
1650 if not Yielded then
1651 Yield;
1652 end if;
1653
1654 -- Caller has been chosen
1655
1656 -- Self_Id.Common.Call should already be updated by the Caller
1657
1658 -- Self_Id.Chosen_Index should either be updated by the Caller
1659 -- or by Test_Selective_Wait
1660
1661 Index := Self_Id.Chosen_Index;
1662 Initialization.Undefer_Abort_Nestable (Self_Id);
1663
1664 -- Start rendezvous, if not already completed
1665 end Timed_Selective_Wait;
1666
1667 ---------------------------
1668 -- Timed_Task_Entry_Call --
1669 ---------------------------
1670
1671 procedure Timed_Task_Entry_Call
1672 (Acceptor : Task_Id;
1673 E : Task_Entry_Index;
1674 Uninterpreted_Data : System.Address;
1675 Timeout : Duration;
1676 Mode : Delay_Modes;
1677 Rendezvous_Successful : out Boolean)
1678 is
1679 Self_Id : constant Task_Id := STPO.Self;
1680 Level : ATC_Level;
1681 Entry_Call : Entry_Call_Link;
1682
1683 Yielded : Boolean;
1684 pragma Unreferenced (Yielded);
1685
1686 begin
1687 -- If pragma Detect_Blocking is active then Program_Error must be
1688 -- raised if this potentially blocking operation is called from a
1689 -- protected action.
1690
1691 if System.Tasking.Detect_Blocking
1692 and then Self_Id.Common.Protected_Action_Nesting > 0
1693 then
1694 raise Program_Error with
1695 "potentially blocking operation";
1696 end if;
1697
1698 Initialization.Defer_Abort (Self_Id);
1699 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1700
1701 pragma Debug
1702 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1703 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1704
1705 if Parameters.Runtime_Traces then
1706 Send_Trace_Info (WT_Call, Acceptor,
1707 Entry_Index (E), Timeout);
1708 end if;
1709
1710 Level := Self_Id.ATC_Nesting_Level;
1711 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1712 Entry_Call.Next := null;
1713 Entry_Call.Mode := Timed_Call;
1714 Entry_Call.Cancellation_Attempted := False;
1715
1716 -- If this is a call made inside of an abort deferred region,
1717 -- the call should be never abortable.
1718
1719 Entry_Call.State :=
1720 (if Self_Id.Deferral_Level > 1
1721 then Never_Abortable
1722 else Now_Abortable);
1723
1724 Entry_Call.E := Entry_Index (E);
1725 Entry_Call.Prio := Get_Priority (Self_Id);
1726 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1727 Entry_Call.Called_Task := Acceptor;
1728 Entry_Call.Called_PO := Null_Address;
1729 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1730 Entry_Call.With_Abort := True;
1731
1732 -- Note: the caller will undefer abort on return (see WARNING above)
1733
1734 if Single_Lock then
1735 Lock_RTS;
1736 end if;
1737
1738 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1739 STPO.Write_Lock (Self_Id);
1740 Utilities.Exit_One_ATC_Level (Self_Id);
1741 STPO.Unlock (Self_Id);
1742
1743 if Single_Lock then
1744 Unlock_RTS;
1745 end if;
1746
1747 Initialization.Undefer_Abort (Self_Id);
1748
1749 if Parameters.Runtime_Traces then
1750 Send_Trace_Info (E_Missed, Acceptor);
1751 end if;
1752 raise Tasking_Error;
1753 end if;
1754
1755 Write_Lock (Self_Id);
1756 Entry_Calls.Wait_For_Completion_With_Timeout
1757 (Entry_Call, Timeout, Mode, Yielded);
1758 Unlock (Self_Id);
1759
1760 if Single_Lock then
1761 Unlock_RTS;
1762 end if;
1763
1764 -- ??? Do we need to yield in case Yielded is False
1765
1766 Rendezvous_Successful := Entry_Call.State = Done;
1767 Initialization.Undefer_Abort (Self_Id);
1768 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1769 end Timed_Task_Entry_Call;
1770
1771 -------------------
1772 -- Wait_For_Call --
1773 -------------------
1774
1775 procedure Wait_For_Call (Self_Id : Task_Id) is
1776 begin
1777 Self_Id.Common.State := Acceptor_Sleep;
1778
1779 -- Try to remove calls to Sleep in the loop below by letting the caller
1780 -- a chance of getting ready immediately, using Unlock & Yield.
1781 -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
1782
1783 if Single_Lock then
1784 Unlock_RTS;
1785 else
1786 Unlock (Self_Id);
1787 end if;
1788
1789 if Self_Id.Open_Accepts /= null then
1790 Yield;
1791 end if;
1792
1793 if Single_Lock then
1794 Lock_RTS;
1795 else
1796 Write_Lock (Self_Id);
1797 end if;
1798
1799 -- Check if this task has been aborted while the lock was released
1800
1801 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1802 Self_Id.Open_Accepts := null;
1803 end if;
1804
1805 loop
1806 exit when Self_Id.Open_Accepts = null;
1807 Sleep (Self_Id, Acceptor_Sleep);
1808 end loop;
1809
1810 Self_Id.Common.State := Runnable;
1811 end Wait_For_Call;
1812
1813 end System.Tasking.Rendezvous;