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