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