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