?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / s-tasren.adb
blobb5e85e15087cdd864ed8cc2b66af6810bc5f11ed
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-2017, 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 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 begin
551 -- The deferral level is critical here, since we want to raise an
552 -- exception or allow abort to take place, if there is an exception or
553 -- abort pending.
554
555 pragma Debug
556 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
557
558 if Ex = Ada.Exceptions.Null_Id then
559
560 -- The call came from normal end-of-rendezvous, so abort is not yet
561 -- deferred.
562
563 if Parameters.Runtime_Traces then
564 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
565 end if;
566
567 Initialization.Defer_Abort (Self_Id);
568
569 elsif ZCX_By_Default then
570
571 -- With ZCX, aborts are not automatically deferred in handlers
572
573 Initialization.Defer_Abort (Self_Id);
574 end if;
575
576 -- We need to clean up any accepts which Self may have been serving when
577 -- it was aborted.
578
579 if Ex = Standard'Abort_Signal'Identity then
580 if Single_Lock then
581 Lock_RTS;
582 end if;
583
584 while Entry_Call /= null loop
585 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
586
587 -- All forms of accept make sure that the acceptor is not
588 -- completed, before accepting further calls, so that we
589 -- can be sure that no further calls are made after the
590 -- current calls are purged.
591
592 Caller := Entry_Call.Self;
593
594 -- Take write lock. This follows the lock precedence rule that
595 -- Caller may be locked while holding lock of Acceptor. Complete
596 -- the call abnormally, with exception.
597
598 STPO.Write_Lock (Caller);
599 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
600 STPO.Unlock (Caller);
601 Entry_Call := Entry_Call.Acceptor_Prev_Call;
602 end loop;
603
604 if Single_Lock then
605 Unlock_RTS;
606 end if;
607
608 else
609 Caller := Entry_Call.Self;
610
611 if Entry_Call.Needs_Requeue then
612
613 -- We dare not lock Self_Id at the same time as Caller, for fear
614 -- of deadlock.
615
616 Entry_Call.Needs_Requeue := False;
617 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
618
619 if Entry_Call.Called_Task /= null then
620
621 -- Requeue to another task entry
622
623 if Single_Lock then
624 Lock_RTS;
625 end if;
626
627 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
628 if Single_Lock then
629 Unlock_RTS;
630 end if;
631
632 Initialization.Undefer_Abort (Self_Id);
633 raise Tasking_Error;
634 end if;
635
636 if Single_Lock then
637 Unlock_RTS;
638 end if;
639
640 else
641 -- Requeue to a protected entry
642
643 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
644 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
645
646 if Ceiling_Violation then
647 pragma Assert (Ex = Ada.Exceptions.Null_Id);
648 Entry_Call.Exception_To_Raise := Program_Error'Identity;
649
650 if Single_Lock then
651 Lock_RTS;
652 end if;
653
654 STPO.Write_Lock (Caller);
655 Initialization.Wakeup_Entry_Caller
656 (Self_Id, Entry_Call, Done);
657 STPO.Unlock (Caller);
658
659 if Single_Lock then
660 Unlock_RTS;
661 end if;
662
663 else
664 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
665 POO.PO_Service_Entries (Self_Id, Called_PO);
666 end if;
667 end if;
668
669 Entry_Calls.Reset_Priority
670 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
671
672 else
673 -- The call does not need to be requeued
674
675 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
676 Entry_Call.Exception_To_Raise := Ex;
677
678 if Single_Lock then
679 Lock_RTS;
680 end if;
681
682 STPO.Write_Lock (Caller);
683
684 -- Done with Caller locked to make sure that Wakeup is not lost
685
686 if Ex /= Ada.Exceptions.Null_Id then
687 Transfer_Occurrence
688 (Caller.Common.Compiler_Data.Current_Excep'Access,
689 Self_Id.Common.Compiler_Data.Current_Excep);
690 end if;
691
692 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
693 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
694
695 STPO.Unlock (Caller);
696
697 if Single_Lock then
698 Unlock_RTS;
699 end if;
700
701 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
702 end if;
703 end if;
704
705 Initialization.Undefer_Abort (Self_Id);
706 end Local_Complete_Rendezvous;
707
708 -------------------------------------
709 -- Requeue_Protected_To_Task_Entry --
710 -------------------------------------
711
712 procedure Requeue_Protected_To_Task_Entry
713 (Object : STPE.Protection_Entries_Access;
714 Acceptor : Task_Id;
715 E : Task_Entry_Index;
716 With_Abort : Boolean)
717 is
718 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
719 begin
720 pragma Assert (STPO.Self.Deferral_Level > 0);
721
722 Entry_Call.E := Entry_Index (E);
723 Entry_Call.Called_Task := Acceptor;
724 Entry_Call.Called_PO := Null_Address;
725 Entry_Call.With_Abort := With_Abort;
726 Object.Call_In_Progress := null;
727 end Requeue_Protected_To_Task_Entry;
728
729 ------------------------
730 -- Requeue_Task_Entry --
731 ------------------------
732
733 procedure Requeue_Task_Entry
734 (Acceptor : Task_Id;
735 E : Task_Entry_Index;
736 With_Abort : Boolean)
737 is
738 Self_Id : constant Task_Id := STPO.Self;
739 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
740 begin
741 Initialization.Defer_Abort (Self_Id);
742 Entry_Call.Needs_Requeue := True;
743 Entry_Call.With_Abort := With_Abort;
744 Entry_Call.E := Entry_Index (E);
745 Entry_Call.Called_Task := Acceptor;
746 Initialization.Undefer_Abort (Self_Id);
747 end Requeue_Task_Entry;
748
749 --------------------
750 -- Selective_Wait --
751 --------------------
752
753 procedure Selective_Wait
754 (Open_Accepts : Accept_List_Access;
755 Select_Mode : Select_Modes;
756 Uninterpreted_Data : out System.Address;
757 Index : out Select_Index)
758 is
759 Self_Id : constant Task_Id := STPO.Self;
760 Entry_Call : Entry_Call_Link;
761 Treatment : Select_Treatment;
762 Caller : Task_Id;
763 Selection : Select_Index;
764 Open_Alternative : Boolean;
765
766 begin
767 Initialization.Defer_Abort (Self_Id);
768
769 if Single_Lock then
770 Lock_RTS;
771 end if;
772
773 STPO.Write_Lock (Self_Id);
774
775 if not Self_Id.Callable then
776 pragma Assert (Self_Id.Pending_ATC_Level = 0);
777
778 pragma Assert (Self_Id.Pending_Action);
779
780 STPO.Unlock (Self_Id);
781
782 if Single_Lock then
783 Unlock_RTS;
784 end if;
785
786 -- ??? In some cases abort is deferred more than once. Need to
787 -- figure out why this happens.
788
789 if Self_Id.Deferral_Level > 1 then
790 Self_Id.Deferral_Level := 1;
791 end if;
792
793 Initialization.Undefer_Abort (Self_Id);
794
795 -- Should never get here ???
796
797 pragma Assert (False);
798 raise Standard'Abort_Signal;
799 end if;
800
801 pragma Assert (Open_Accepts /= null);
802
803 Uninterpreted_Data := Null_Address;
804
805 Queuing.Select_Task_Entry_Call
806 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
807
808 -- Determine the kind and disposition of the select
809
810 Treatment := Default_Treatment (Select_Mode);
811 Self_Id.Chosen_Index := No_Rendezvous;
812
813 if Open_Alternative then
814 if Entry_Call /= null then
815 if Open_Accepts (Selection).Null_Body then
816 Treatment := Accept_Alternative_Completed;
817 else
818 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
819 Treatment := Accept_Alternative_Selected;
820 end if;
821
822 Self_Id.Chosen_Index := Selection;
823
824 elsif Treatment = No_Alternative_Open then
825 Treatment := Accept_Alternative_Open;
826 end if;
827 end if;
828
829 -- Handle the select according to the disposition selected above
830
831 case Treatment is
832 when Accept_Alternative_Selected =>
833
834 -- Ready to rendezvous
835
836 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
837
838 -- In this case the accept body is not Null_Body. Defer abort
839 -- until it gets into the accept body. The compiler has inserted
840 -- a call to Abort_Undefer as part of the entry expansion.
841
842 pragma Assert (Self_Id.Deferral_Level = 1);
843
844 Initialization.Defer_Abort_Nestable (Self_Id);
845 STPO.Unlock (Self_Id);
846
847 when Accept_Alternative_Completed =>
848
849 -- Accept body is null, so rendezvous is over immediately
850
851 if Parameters.Runtime_Traces then
852 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
853 end if;
854
855 STPO.Unlock (Self_Id);
856 Caller := Entry_Call.Self;
857
858 STPO.Write_Lock (Caller);
859 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
860 STPO.Unlock (Caller);
861
862 when Accept_Alternative_Open =>
863
864 -- Wait for caller
865
866 Self_Id.Open_Accepts := Open_Accepts;
867 pragma Debug
868 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
869
870 if Parameters.Runtime_Traces then
871 Send_Trace_Info (W_Select, Self_Id,
872 Integer (Open_Accepts'Length));
873 end if;
874
875 Wait_For_Call (Self_Id);
876
877 pragma Assert (Self_Id.Open_Accepts = null);
878
879 -- Self_Id.Common.Call should already be updated by the Caller if
880 -- not aborted. It might also be ready to do rendezvous even if
881 -- this wakes up due to an abort. Therefore, if the call is not
882 -- empty we need to do the rendezvous if the accept body is not
883 -- Null_Body.
884
885 -- Aren't the first two conditions below redundant???
886
887 if Self_Id.Chosen_Index /= No_Rendezvous
888 and then Self_Id.Common.Call /= null
889 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
890 then
891 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
892
893 pragma Assert
894 (Self_Id.Deferral_Level = 1
895 or else
896 (Self_Id.Deferral_Level = 0
897 and then not Restrictions.Abort_Allowed));
898
899 Initialization.Defer_Abort_Nestable (Self_Id);
900
901 -- Leave abort deferred until the accept body
902 -- The compiler has inserted a call to Abort_Undefer as part of
903 -- the entry expansion.
904 end if;
905
906 STPO.Unlock (Self_Id);
907
908 when Else_Selected =>
909 pragma Assert (Self_Id.Open_Accepts = null);
910
911 if Parameters.Runtime_Traces then
912 Send_Trace_Info (M_Select_Else);
913 end if;
914
915 STPO.Unlock (Self_Id);
916
917 when Terminate_Selected =>
918
919 -- Terminate alternative is open
920
921 Self_Id.Open_Accepts := Open_Accepts;
922 Self_Id.Common.State := Acceptor_Sleep;
923
924 -- Notify ancestors that this task is on a terminate alternative
925
926 STPO.Unlock (Self_Id);
927 Utilities.Make_Passive (Self_Id, Task_Completed => False);
928 STPO.Write_Lock (Self_Id);
929
930 -- Wait for normal entry call or termination
931
932 Wait_For_Call (Self_Id);
933
934 pragma Assert (Self_Id.Open_Accepts = null);
935
936 if Self_Id.Terminate_Alternative then
937
938 -- An entry call should have reset this to False, so we must be
939 -- aborted. We cannot be in an async. select, since that is not
940 -- legal, so the abort must be of the entire task. Therefore,
941 -- we do not need to cancel the terminate alternative. The
942 -- cleanup will be done in Complete_Master.
943
944 pragma Assert (Self_Id.Pending_ATC_Level = 0);
945 pragma Assert (Self_Id.Awake_Count = 0);
946
947 STPO.Unlock (Self_Id);
948
949 if Single_Lock then
950 Unlock_RTS;
951 end if;
952
953 Index := Self_Id.Chosen_Index;
954 Initialization.Undefer_Abort_Nestable (Self_Id);
955
956 if Self_Id.Pending_Action then
957 Initialization.Do_Pending_Action (Self_Id);
958 end if;
959
960 return;
961
962 else
963 -- Self_Id.Common.Call and Self_Id.Chosen_Index
964 -- should already be updated by the Caller.
965
966 if Self_Id.Chosen_Index /= No_Rendezvous
967 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
968 then
969 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
970
971 pragma Assert (Self_Id.Deferral_Level = 1);
972
973 -- We need an extra defer here, to keep abort
974 -- deferred until we get into the accept body
975 -- The compiler has inserted a call to Abort_Undefer as part
976 -- of the entry expansion.
977
978 Initialization.Defer_Abort_Nestable (Self_Id);
979 end if;
980 end if;
981
982 STPO.Unlock (Self_Id);
983
984 when No_Alternative_Open =>
985
986 -- In this case, Index will be No_Rendezvous on return, which
987 -- should cause a Program_Error if it is not a Delay_Mode.
988
989 -- If delay alternative exists (Delay_Mode) we should suspend
990 -- until the delay expires.
991
992 Self_Id.Open_Accepts := null;
993
994 if Select_Mode = Delay_Mode then
995 Self_Id.Common.State := Delay_Sleep;
996
997 loop
998 exit when
999 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1000 Sleep (Self_Id, Delay_Sleep);
1001 end loop;
1002
1003 Self_Id.Common.State := Runnable;
1004 STPO.Unlock (Self_Id);
1005
1006 else
1007 STPO.Unlock (Self_Id);
1008
1009 if Single_Lock then
1010 Unlock_RTS;
1011 end if;
1012
1013 Initialization.Undefer_Abort (Self_Id);
1014 raise Program_Error with
1015 "entry call not a delay mode";
1016 end if;
1017 end case;
1018
1019 if Single_Lock then
1020 Unlock_RTS;
1021 end if;
1022
1023 -- Caller has been chosen
1024
1025 -- Self_Id.Common.Call should already be updated by the Caller.
1026
1027 -- Self_Id.Chosen_Index should either be updated by the Caller
1028 -- or by Test_Selective_Wait.
1029
1030 -- On return, we sill start rendezvous unless the accept body is
1031 -- null. In the latter case, we will have already completed the RV.
1032
1033 Index := Self_Id.Chosen_Index;
1034 Initialization.Undefer_Abort_Nestable (Self_Id);
1035 end Selective_Wait;
1036
1037 ------------------------------------
1038 -- Setup_For_Rendezvous_With_Body --
1039 ------------------------------------
1040
1041 procedure Setup_For_Rendezvous_With_Body
1042 (Entry_Call : Entry_Call_Link;
1043 Acceptor : Task_Id) is
1044 begin
1045 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1046 Acceptor.Common.Call := Entry_Call;
1047
1048 if Entry_Call.State = Now_Abortable then
1049 Entry_Call.State := Was_Abortable;
1050 end if;
1051
1052 Boost_Priority (Entry_Call, Acceptor);
1053 end Setup_For_Rendezvous_With_Body;
1054
1055 ----------------
1056 -- Task_Count --
1057 ----------------
1058
1059 function Task_Count (E : Task_Entry_Index) return Natural is
1060 Self_Id : constant Task_Id := STPO.Self;
1061 Return_Count : Natural;
1062
1063 begin
1064 Initialization.Defer_Abort (Self_Id);
1065
1066 if Single_Lock then
1067 Lock_RTS;
1068 end if;
1069
1070 STPO.Write_Lock (Self_Id);
1071 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1072 STPO.Unlock (Self_Id);
1073
1074 if Single_Lock then
1075 Unlock_RTS;
1076 end if;
1077
1078 Initialization.Undefer_Abort (Self_Id);
1079
1080 return Return_Count;
1081 end Task_Count;
1082
1083 ----------------------
1084 -- Task_Do_Or_Queue --
1085 ----------------------
1086
1087 function Task_Do_Or_Queue
1088 (Self_ID : Task_Id;
1089 Entry_Call : Entry_Call_Link) return Boolean
1090 is
1091 E : constant Task_Entry_Index :=
1092 Task_Entry_Index (Entry_Call.E);
1093 Old_State : constant Entry_Call_State := Entry_Call.State;
1094 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1095 Parent : constant Task_Id := Acceptor.Common.Parent;
1096 Null_Body : Boolean;
1097
1098 begin
1099 -- Find out whether Entry_Call can be accepted immediately
1100
1101 -- If the Acceptor is not callable, return False.
1102 -- If the rendezvous can start, initiate it.
1103 -- If the accept-body is trivial, also complete the rendezvous.
1104 -- If the acceptor is not ready, enqueue the call.
1105
1106 -- This should have a special case for Accept_Call and Accept_Trivial,
1107 -- so that we don't have the loop setup overhead, below.
1108
1109 -- The call state Done is used here and elsewhere to include both the
1110 -- case of normal successful completion, and the case of an exception
1111 -- being raised. The difference is that if an exception is raised no one
1112 -- will pay attention to the fact that State = Done. Instead the
1113 -- exception will be raised in Undefer_Abort, and control will skip past
1114 -- the place where we normally would resume from an entry call.
1115
1116 pragma Assert (not Queuing.Onqueue (Entry_Call));
1117
1118 -- We rely that the call is off-queue for protection, that the caller
1119 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1120 -- record for another call. We rely on the Caller's lock for call State
1121 -- mod's.
1122
1123 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1124 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1125 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor
1126 -- is locked. Therefore, we need to lock both. Attempts to avoid locking
1127 -- Parent tend to result in race conditions. It would work to unlock
1128 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be
1129 -- False, but that violates the rule of properly nested locking (see
1130 -- System.Tasking).
1131
1132 STPO.Write_Lock (Parent);
1133 STPO.Write_Lock (Acceptor);
1134
1135 -- If the acceptor is not callable, abort the call and return False
1136
1137 if not Acceptor.Callable then
1138 STPO.Unlock (Acceptor);
1139 STPO.Unlock (Parent);
1140
1141 pragma Assert (Entry_Call.State < Done);
1142
1143 -- In case we are not the caller, set up the caller
1144 -- to raise Tasking_Error when it wakes up.
1145
1146 STPO.Write_Lock (Entry_Call.Self);
1147 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1148 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1149 STPO.Unlock (Entry_Call.Self);
1150
1151 return False;
1152 end if;
1153
1154 -- Try to serve the call immediately
1155
1156 if Acceptor.Open_Accepts /= null then
1157 for J in Acceptor.Open_Accepts'Range loop
1158 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1159
1160 -- Commit acceptor to rendezvous with us
1161
1162 Acceptor.Chosen_Index := J;
1163 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1164 Acceptor.Open_Accepts := null;
1165
1166 -- Prevent abort while call is being served
1167
1168 if Entry_Call.State = Now_Abortable then
1169 Entry_Call.State := Was_Abortable;
1170 end if;
1171
1172 if Acceptor.Terminate_Alternative then
1173
1174 -- Cancel terminate alternative. See matching code in
1175 -- Selective_Wait and Vulnerable_Complete_Master.
1176
1177 Acceptor.Terminate_Alternative := False;
1178 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1179
1180 if Acceptor.Awake_Count = 1 then
1181
1182 -- Notify parent that acceptor is awake
1183
1184 pragma Assert (Parent.Awake_Count > 0);
1185
1186 Parent.Awake_Count := Parent.Awake_Count + 1;
1187
1188 if Parent.Common.State = Master_Completion_Sleep
1189 and then Acceptor.Master_of_Task = Parent.Master_Within
1190 then
1191 Parent.Common.Wait_Count :=
1192 Parent.Common.Wait_Count + 1;
1193 end if;
1194 end if;
1195 end if;
1196
1197 if Null_Body then
1198
1199 -- Rendezvous is over immediately
1200
1201 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1202 STPO.Unlock (Acceptor);
1203 STPO.Unlock (Parent);
1204
1205 STPO.Write_Lock (Entry_Call.Self);
1206 Initialization.Wakeup_Entry_Caller
1207 (Self_ID, Entry_Call, Done);
1208 STPO.Unlock (Entry_Call.Self);
1209
1210 else
1211 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1212
1213 -- For terminate_alternative, acceptor may not be asleep
1214 -- yet, so we skip the wakeup
1215
1216 if Acceptor.Common.State /= Runnable then
1217 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1218 end if;
1219
1220 STPO.Unlock (Acceptor);
1221 STPO.Unlock (Parent);
1222 end if;
1223
1224 return True;
1225 end if;
1226 end loop;
1227
1228 -- The acceptor is accepting, but not this entry
1229 end if;
1230
1231 -- If the acceptor was ready to accept this call,
1232 -- we would not have gotten this far, so now we should
1233 -- (re)enqueue the call, if the mode permits that.
1234
1235 -- If the call is timed, it may have timed out before the requeue,
1236 -- in the unusual case where the current accept has taken longer than
1237 -- the given delay. In that case the requeue is cancelled, and the
1238 -- outer timed call will be aborted.
1239
1240 if Entry_Call.Mode = Conditional_Call
1241 or else
1242 (Entry_Call.Mode = Timed_Call
1243 and then Entry_Call.With_Abort
1244 and then Entry_Call.Cancellation_Attempted)
1245 then
1246 STPO.Unlock (Acceptor);
1247 STPO.Unlock (Parent);
1248
1249 STPO.Write_Lock (Entry_Call.Self);
1250
1251 pragma Assert (Entry_Call.State >= Was_Abortable);
1252
1253 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1254 STPO.Unlock (Entry_Call.Self);
1255
1256 else
1257 -- Timed_Call, Simple_Call, or Asynchronous_Call
1258
1259 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1260
1261 -- Update abortability of call
1262
1263 pragma Assert (Old_State < Done);
1264
1265 Entry_Call.State :=
1266 New_State (Entry_Call.With_Abort, Entry_Call.State);
1267
1268 STPO.Unlock (Acceptor);
1269 STPO.Unlock (Parent);
1270
1271 if Old_State /= Entry_Call.State
1272 and then Entry_Call.State = Now_Abortable
1273 and then Entry_Call.Mode /= Simple_Call
1274 and then Entry_Call.Self /= Self_ID
1275
1276 -- Asynchronous_Call or Conditional_Call
1277
1278 then
1279 -- Because of ATCB lock ordering rule
1280
1281 STPO.Write_Lock (Entry_Call.Self);
1282
1283 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1284
1285 -- Caller may not yet have reached wait-point
1286
1287 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1288 end if;
1289
1290 STPO.Unlock (Entry_Call.Self);
1291 end if;
1292 end if;
1293
1294 return True;
1295 end Task_Do_Or_Queue;
1296
1297 ---------------------
1298 -- Task_Entry_Call --
1299 ---------------------
1300
1301 procedure Task_Entry_Call
1302 (Acceptor : Task_Id;
1303 E : Task_Entry_Index;
1304 Uninterpreted_Data : System.Address;
1305 Mode : Call_Modes;
1306 Rendezvous_Successful : out Boolean)
1307 is
1308 Self_Id : constant Task_Id := STPO.Self;
1309 Entry_Call : Entry_Call_Link;
1310
1311 begin
1312 -- If pragma Detect_Blocking is active then Program_Error must be
1313 -- raised if this potentially blocking operation is called from a
1314 -- protected action.
1315
1316 if System.Tasking.Detect_Blocking
1317 and then Self_Id.Common.Protected_Action_Nesting > 0
1318 then
1319 raise Program_Error with
1320 "potentially blocking operation";
1321 end if;
1322
1323 if Parameters.Runtime_Traces then
1324 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1325 end if;
1326
1327 if Mode = Simple_Call or else Mode = Conditional_Call then
1328 Call_Synchronous
1329 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1330
1331 else
1332 -- This is an asynchronous call
1333
1334 -- Abort must already be deferred by the compiler-generated code.
1335 -- Without this, an abort that occurs between the time that this
1336 -- call is made and the time that the abortable part's cleanup
1337 -- handler is set up might miss the cleanup handler and leave the
1338 -- call pending.
1339
1340 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1341 pragma Debug
1342 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1343 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1344 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1345 Entry_Call.Next := null;
1346 Entry_Call.Mode := Mode;
1347 Entry_Call.Cancellation_Attempted := False;
1348 Entry_Call.State := Not_Yet_Abortable;
1349 Entry_Call.E := Entry_Index (E);
1350 Entry_Call.Prio := Get_Priority (Self_Id);
1351 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1352 Entry_Call.Called_Task := Acceptor;
1353 Entry_Call.Called_PO := Null_Address;
1354 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1355 Entry_Call.With_Abort := True;
1356
1357 if Single_Lock then
1358 Lock_RTS;
1359 end if;
1360
1361 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1362 STPO.Write_Lock (Self_Id);
1363 Utilities.Exit_One_ATC_Level (Self_Id);
1364 STPO.Unlock (Self_Id);
1365
1366 if Single_Lock then
1367 Unlock_RTS;
1368 end if;
1369
1370 Initialization.Undefer_Abort (Self_Id);
1371
1372 if Parameters.Runtime_Traces then
1373 Send_Trace_Info (E_Missed, Acceptor);
1374 end if;
1375
1376 raise Tasking_Error;
1377 end if;
1378
1379 -- The following is special for async. entry calls. If the call was
1380 -- not queued abortably, we need to wait until it is before
1381 -- proceeding with the abortable part.
1382
1383 -- Wait_Until_Abortable can be called unconditionally here, but it is
1384 -- expensive.
1385
1386 if Entry_Call.State < Was_Abortable then
1387 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1388 end if;
1389
1390 if Single_Lock then
1391 Unlock_RTS;
1392 end if;
1393
1394 -- Note: following assignment needs to be atomic
1395
1396 Rendezvous_Successful := Entry_Call.State = Done;
1397 end if;
1398 end Task_Entry_Call;
1399
1400 -----------------------
1401 -- Task_Entry_Caller --
1402 -----------------------
1403
1404 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1405 Self_Id : constant Task_Id := STPO.Self;
1406 Entry_Call : Entry_Call_Link;
1407
1408 begin
1409 Entry_Call := Self_Id.Common.Call;
1410
1411 for Depth in 1 .. D loop
1412 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1413 pragma Assert (Entry_Call /= null);
1414 end loop;
1415
1416 return Entry_Call.Self;
1417 end Task_Entry_Caller;
1418
1419 --------------------------
1420 -- Timed_Selective_Wait --
1421 --------------------------
1422
1423 procedure Timed_Selective_Wait
1424 (Open_Accepts : Accept_List_Access;
1425 Select_Mode : Select_Modes;
1426 Uninterpreted_Data : out System.Address;
1427 Timeout : Duration;
1428 Mode : Delay_Modes;
1429 Index : out Select_Index)
1430 is
1431 Self_Id : constant Task_Id := STPO.Self;
1432 Treatment : Select_Treatment;
1433 Entry_Call : Entry_Call_Link;
1434 Caller : Task_Id;
1435 Selection : Select_Index;
1436 Open_Alternative : Boolean;
1437 Timedout : Boolean := False;
1438 Yielded : Boolean := True;
1439
1440 begin
1441 pragma Assert (Select_Mode = Delay_Mode);
1442
1443 Initialization.Defer_Abort (Self_Id);
1444
1445 -- If we are aborted here, the effect will be pending
1446
1447 if Single_Lock then
1448 Lock_RTS;
1449 end if;
1450
1451 STPO.Write_Lock (Self_Id);
1452
1453 if not Self_Id.Callable then
1454 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1455
1456 pragma Assert (Self_Id.Pending_Action);
1457
1458 STPO.Unlock (Self_Id);
1459
1460 if Single_Lock then
1461 Unlock_RTS;
1462 end if;
1463
1464 Initialization.Undefer_Abort (Self_Id);
1465
1466 -- Should never get here ???
1467
1468 pragma Assert (False);
1469 raise Standard'Abort_Signal;
1470 end if;
1471
1472 Uninterpreted_Data := Null_Address;
1473
1474 pragma Assert (Open_Accepts /= null);
1475
1476 Queuing.Select_Task_Entry_Call
1477 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1478
1479 -- Determine the kind and disposition of the select
1480
1481 Treatment := Default_Treatment (Select_Mode);
1482 Self_Id.Chosen_Index := No_Rendezvous;
1483
1484 if Open_Alternative then
1485 if Entry_Call /= null then
1486 if Open_Accepts (Selection).Null_Body then
1487 Treatment := Accept_Alternative_Completed;
1488
1489 else
1490 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1491 Treatment := Accept_Alternative_Selected;
1492 end if;
1493
1494 Self_Id.Chosen_Index := Selection;
1495
1496 elsif Treatment = No_Alternative_Open then
1497 Treatment := Accept_Alternative_Open;
1498 end if;
1499 end if;
1500
1501 -- Handle the select according to the disposition selected above
1502
1503 case Treatment is
1504 when Accept_Alternative_Selected =>
1505
1506 -- Ready to rendezvous. In this case the accept body is not
1507 -- Null_Body. Defer abort until it gets into the accept body.
1508
1509 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1510 Initialization.Defer_Abort_Nestable (Self_Id);
1511 STPO.Unlock (Self_Id);
1512
1513 when Accept_Alternative_Completed =>
1514
1515 -- Rendezvous is over
1516
1517 if Parameters.Runtime_Traces then
1518 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1519 end if;
1520
1521 STPO.Unlock (Self_Id);
1522 Caller := Entry_Call.Self;
1523
1524 STPO.Write_Lock (Caller);
1525 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1526 STPO.Unlock (Caller);
1527
1528 when Accept_Alternative_Open =>
1529
1530 -- Wait for caller
1531
1532 Self_Id.Open_Accepts := Open_Accepts;
1533
1534 -- Wait for a normal call and a pending action until the
1535 -- Wakeup_Time is reached.
1536
1537 Self_Id.Common.State := Acceptor_Delay_Sleep;
1538
1539 -- Try to remove calls to Sleep in the loop below by letting the
1540 -- caller a chance of getting ready immediately, using Unlock
1541 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1542
1543 if Single_Lock then
1544 Unlock_RTS;
1545 else
1546 Unlock (Self_Id);
1547 end if;
1548
1549 if Self_Id.Open_Accepts /= null then
1550 Yield;
1551 end if;
1552
1553 if Single_Lock then
1554 Lock_RTS;
1555 else
1556 Write_Lock (Self_Id);
1557 end if;
1558
1559 -- Check if this task has been aborted while the lock was released
1560
1561 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1562 Self_Id.Open_Accepts := null;
1563 end if;
1564
1565 loop
1566 exit when Self_Id.Open_Accepts = null;
1567
1568 if Timedout then
1569 Sleep (Self_Id, Acceptor_Delay_Sleep);
1570 else
1571 if Parameters.Runtime_Traces then
1572 Send_Trace_Info (WT_Select,
1573 Self_Id,
1574 Integer (Open_Accepts'Length),
1575 Timeout);
1576 end if;
1577
1578 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1579 Acceptor_Delay_Sleep, Timedout, Yielded);
1580 end if;
1581
1582 if Timedout then
1583 Self_Id.Open_Accepts := null;
1584
1585 if Parameters.Runtime_Traces then
1586 Send_Trace_Info (E_Timeout);
1587 end if;
1588 end if;
1589 end loop;
1590
1591 Self_Id.Common.State := Runnable;
1592
1593 -- Self_Id.Common.Call should already be updated by the Caller if
1594 -- not aborted. It might also be ready to do rendezvous even if
1595 -- this wakes up due to an abort. Therefore, if the call is not
1596 -- empty we need to do the rendezvous if the accept body is not
1597 -- Null_Body.
1598
1599 if Self_Id.Chosen_Index /= No_Rendezvous
1600 and then Self_Id.Common.Call /= null
1601 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1602 then
1603 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1604
1605 pragma Assert (Self_Id.Deferral_Level = 1);
1606
1607 Initialization.Defer_Abort_Nestable (Self_Id);
1608
1609 -- Leave abort deferred until the accept body
1610 end if;
1611
1612 STPO.Unlock (Self_Id);
1613
1614 when No_Alternative_Open =>
1615
1616 -- In this case, Index will be No_Rendezvous on return. We sleep
1617 -- for the time we need to.
1618
1619 -- Wait for a signal or timeout. A wakeup can be made
1620 -- for several reasons:
1621 -- 1) Delay is expired
1622 -- 2) Pending_Action needs to be checked
1623 -- (Abort, Priority change)
1624 -- 3) Spurious wakeup
1625
1626 Self_Id.Open_Accepts := null;
1627 Self_Id.Common.State := Acceptor_Delay_Sleep;
1628
1629 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1630 Timedout, Yielded);
1631
1632 Self_Id.Common.State := Runnable;
1633
1634 STPO.Unlock (Self_Id);
1635
1636 when others =>
1637
1638 -- Should never get here
1639
1640 pragma Assert (False);
1641 null;
1642 end case;
1643
1644 if Single_Lock then
1645 Unlock_RTS;
1646 end if;
1647
1648 if not Yielded then
1649 Yield;
1650 end if;
1651
1652 -- Caller has been chosen
1653
1654 -- Self_Id.Common.Call should already be updated by the Caller
1655
1656 -- Self_Id.Chosen_Index should either be updated by the Caller
1657 -- or by Test_Selective_Wait
1658
1659 Index := Self_Id.Chosen_Index;
1660 Initialization.Undefer_Abort_Nestable (Self_Id);
1661
1662 -- Start rendezvous, if not already completed
1663 end Timed_Selective_Wait;
1664
1665 ---------------------------
1666 -- Timed_Task_Entry_Call --
1667 ---------------------------
1668
1669 procedure Timed_Task_Entry_Call
1670 (Acceptor : Task_Id;
1671 E : Task_Entry_Index;
1672 Uninterpreted_Data : System.Address;
1673 Timeout : Duration;
1674 Mode : Delay_Modes;
1675 Rendezvous_Successful : out Boolean)
1676 is
1677 Self_Id : constant Task_Id := STPO.Self;
1678 Level : ATC_Level;
1679 Entry_Call : Entry_Call_Link;
1680
1681 Yielded : Boolean;
1682 pragma Unreferenced (Yielded);
1683
1684 begin
1685 -- If pragma Detect_Blocking is active then Program_Error must be
1686 -- raised if this potentially blocking operation is called from a
1687 -- protected action.
1688
1689 if System.Tasking.Detect_Blocking
1690 and then Self_Id.Common.Protected_Action_Nesting > 0
1691 then
1692 raise Program_Error with
1693 "potentially blocking operation";
1694 end if;
1695
1696 Initialization.Defer_Abort (Self_Id);
1697 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1698
1699 pragma Debug
1700 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1701 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1702
1703 if Parameters.Runtime_Traces then
1704 Send_Trace_Info (WT_Call, Acceptor,
1705 Entry_Index (E), Timeout);
1706 end if;
1707
1708 Level := Self_Id.ATC_Nesting_Level;
1709 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1710 Entry_Call.Next := null;
1711 Entry_Call.Mode := Timed_Call;
1712 Entry_Call.Cancellation_Attempted := False;
1713
1714 -- If this is a call made inside of an abort deferred region,
1715 -- the call should be never abortable.
1716
1717 Entry_Call.State :=
1718 (if Self_Id.Deferral_Level > 1
1719 then Never_Abortable
1720 else Now_Abortable);
1721
1722 Entry_Call.E := Entry_Index (E);
1723 Entry_Call.Prio := Get_Priority (Self_Id);
1724 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1725 Entry_Call.Called_Task := Acceptor;
1726 Entry_Call.Called_PO := Null_Address;
1727 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1728 Entry_Call.With_Abort := True;
1729
1730 -- Note: the caller will undefer abort on return (see WARNING above)
1731
1732 if Single_Lock then
1733 Lock_RTS;
1734 end if;
1735
1736 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1737 STPO.Write_Lock (Self_Id);
1738 Utilities.Exit_One_ATC_Level (Self_Id);
1739 STPO.Unlock (Self_Id);
1740
1741 if Single_Lock then
1742 Unlock_RTS;
1743 end if;
1744
1745 Initialization.Undefer_Abort (Self_Id);
1746
1747 if Parameters.Runtime_Traces then
1748 Send_Trace_Info (E_Missed, Acceptor);
1749 end if;
1750 raise Tasking_Error;
1751 end if;
1752
1753 Write_Lock (Self_Id);
1754 Entry_Calls.Wait_For_Completion_With_Timeout
1755 (Entry_Call, Timeout, Mode, Yielded);
1756 Unlock (Self_Id);
1757
1758 if Single_Lock then
1759 Unlock_RTS;
1760 end if;
1761
1762 -- ??? Do we need to yield in case Yielded is False
1763
1764 Rendezvous_Successful := Entry_Call.State = Done;
1765 Initialization.Undefer_Abort (Self_Id);
1766 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1767 end Timed_Task_Entry_Call;
1768
1769 -------------------
1770 -- Wait_For_Call --
1771 -------------------
1772
1773 procedure Wait_For_Call (Self_Id : Task_Id) is
1774 begin
1775 Self_Id.Common.State := Acceptor_Sleep;
1776
1777 -- Try to remove calls to Sleep in the loop below by letting the caller
1778 -- a chance of getting ready immediately, using Unlock & Yield.
1779 -- See similar action in Wait_For_Completion & Timed_Selective_Wait.
1780
1781 if Single_Lock then
1782 Unlock_RTS;
1783 else
1784 Unlock (Self_Id);
1785 end if;
1786
1787 if Self_Id.Open_Accepts /= null then
1788 Yield;
1789 end if;
1790
1791 if Single_Lock then
1792 Lock_RTS;
1793 else
1794 Write_Lock (Self_Id);
1795 end if;
1796
1797 -- Check if this task has been aborted while the lock was released
1798
1799 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1800 Self_Id.Open_Accepts := null;
1801 end if;
1802
1803 loop
1804 exit when Self_Id.Open_Accepts = null;
1805 Sleep (Self_Id, Acceptor_Sleep);
1806 end loop;
1807
1808 Self_Id.Common.State := Runnable;
1809 end Wait_For_Call;
1810
1811 end System.Tasking.Rendezvous;
Mirror of the offical gcc git repository hosted at gcc.gnu.org