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