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