?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
mips.h (set_volatile): Delete.
[official-gcc.git] / gcc / ada / s-tasren.adb
blob40111c8fd3a27f2835e12511d55c20c9966213f7
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-2007, 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 System.Task_Primitives.Operations;
35 -- used for Get_Priority
36 -- Set_Priority
37 -- Write_Lock
38 -- Unlock
39 -- Sleep
40 -- Wakeup
41 -- Timed_Sleep
42
43 with System.Tasking.Entry_Calls;
44 -- Used for Wait_For_Completion
45 -- Wait_For_Completion_With_Timeout
46 -- Wait_Until_Abortable
47
48 with System.Tasking.Initialization;
49 -- used for Defer_Abort
50 -- Undefer_Abort
51 -- Do_Pending_Action
52
53 with System.Tasking.Queuing;
54 -- used for Enqueue
55 -- Dequeue_Head
56 -- Select_Task_Entry_Call
57 -- Count_Waiting
58
59 with System.Tasking.Utilities;
60 -- used for Check_Exception
61 -- Make_Passive
62 -- Wakeup_Entry_Caller
63 -- Exit_One_ATC_Level
64
65 with System.Tasking.Protected_Objects.Operations;
66 -- used for PO_Do_Or_Queue
67 -- PO_Service_Entries
68 -- Lock_Entries
69
70 with System.Tasking.Debug;
71 -- used for Trace
72
73 with System.Restrictions;
74 -- used for Abort_Allowed
75
76 with System.Parameters;
77 -- used for Single_Lock
78 -- Runtime_Traces
79
80 with System.Traces.Tasking;
81 -- used for Send_Trace_Info
82
83 package body System.Tasking.Rendezvous is
84
85 package STPO renames System.Task_Primitives.Operations;
86 package POO renames Protected_Objects.Operations;
87 package POE renames Protected_Objects.Entries;
88
89 use Parameters;
90 use Task_Primitives.Operations;
91 use System.Traces;
92 use System.Traces.Tasking;
93
94 type Select_Treatment is (
95 Accept_Alternative_Selected, -- alternative with non-null body
96 Accept_Alternative_Completed, -- alternative with null body
97 Else_Selected,
98 Terminate_Selected,
99 Accept_Alternative_Open,
100 No_Alternative_Open);
101
102 ----------------
103 -- Local Data --
104 ----------------
105
106 Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
107 (Simple_Mode => No_Alternative_Open,
108 Else_Mode => Else_Selected,
109 Terminate_Mode => Terminate_Selected,
110 Delay_Mode => No_Alternative_Open);
111
112 New_State : constant array (Boolean, Entry_Call_State)
113 of Entry_Call_State :=
114 (True =>
115 (Never_Abortable => Never_Abortable,
116 Not_Yet_Abortable => Now_Abortable,
117 Was_Abortable => Now_Abortable,
118 Now_Abortable => Now_Abortable,
119 Done => Done,
120 Cancelled => Cancelled),
121 False =>
122 (Never_Abortable => Never_Abortable,
123 Not_Yet_Abortable => Not_Yet_Abortable,
124 Was_Abortable => Was_Abortable,
125 Now_Abortable => Now_Abortable,
126 Done => Done,
127 Cancelled => Cancelled)
128 );
129
130 -----------------------
131 -- Local Subprograms --
132 -----------------------
133
134 procedure Local_Defer_Abort (Self_Id : Task_Id) renames
135 System.Tasking.Initialization.Defer_Abort_Nestable;
136
137 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
138 System.Tasking.Initialization.Undefer_Abort_Nestable;
139
140 -- Florist defers abort around critical sections that
141 -- make entry calls to the Interrupt_Manager task, which
142 -- violates the general rule about top-level runtime system
143 -- calls from abort-deferred regions. It is not that this is
144 -- unsafe, but when it occurs in "normal" programs it usually
145 -- means either the user is trying to do a potentially blocking
146 -- operation from within a protected object, or there is a
147 -- runtime system/compiler error that has failed to undefer
148 -- an earlier abort deferral. Thus, for debugging it may be
149 -- wise to modify the above renamings to the non-nestable forms.
150
151 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
152 pragma Inline (Boost_Priority);
153 -- Call this only with abort deferred and holding lock of Acceptor
154
155 procedure Call_Synchronous
156 (Acceptor : Task_Id;
157 E : Task_Entry_Index;
158 Uninterpreted_Data : System.Address;
159 Mode : Call_Modes;
160 Rendezvous_Successful : out Boolean);
161 pragma Inline (Call_Synchronous);
162 -- This call is used to make a simple or conditional entry call.
163 -- Called from Call_Simple and Task_Entry_Call.
164
165 procedure Setup_For_Rendezvous_With_Body
166 (Entry_Call : Entry_Call_Link;
167 Acceptor : Task_Id);
168 pragma Inline (Setup_For_Rendezvous_With_Body);
169 -- Call this only with abort deferred and holding lock of Acceptor.
170 -- When a rendezvous selected (ready for rendezvous) we need to save
171 -- previous caller and adjust the priority. Also we need to make
172 -- this call not Abortable (Cancellable) since the rendezvous has
173 -- already been started.
174
175 procedure Wait_For_Call (Self_Id : Task_Id);
176 pragma Inline (Wait_For_Call);
177 -- Call this only with abort deferred and holding lock of Self_Id.
178 -- An accepting task goes into Sleep by calling this routine
179 -- waiting for a call from the caller or waiting for an abort.
180 -- Make sure Self_Id is locked before calling this routine.
181
182 -----------------
183 -- Accept_Call --
184 -----------------
185
186 procedure Accept_Call
187 (E : Task_Entry_Index;
188 Uninterpreted_Data : out System.Address)
189 is
190 Self_Id : constant Task_Id := STPO.Self;
191 Caller : Task_Id := null;
192 Open_Accepts : aliased Accept_List (1 .. 1);
193 Entry_Call : Entry_Call_Link;
194
195 begin
196 Initialization.Defer_Abort (Self_Id);
197
198 if Single_Lock then
199 Lock_RTS;
200 end if;
201
202 STPO.Write_Lock (Self_Id);
203
204 if not Self_Id.Callable then
205 pragma Assert (Self_Id.Pending_ATC_Level = 0);
206
207 pragma Assert (Self_Id.Pending_Action);
208
209 STPO.Unlock (Self_Id);
210
211 if Single_Lock then
212 Unlock_RTS;
213 end if;
214
215 Initialization.Undefer_Abort (Self_Id);
216
217 -- Should never get here ???
218
219 pragma Assert (False);
220 raise Standard'Abort_Signal;
221 end if;
222
223 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
224
225 if Entry_Call /= null then
226 Caller := Entry_Call.Self;
227 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
228 Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
229
230 else
231 -- Wait for a caller
232
233 Open_Accepts (1).Null_Body := False;
234 Open_Accepts (1).S := E;
235 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
236
237 -- Wait for normal call
238
239 if Parameters.Runtime_Traces then
240 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
241 end if;
242
243 pragma Debug
244 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
245 Wait_For_Call (Self_Id);
246
247 pragma Assert (Self_Id.Open_Accepts = null);
248
249 if Self_Id.Common.Call /= null then
250 Caller := Self_Id.Common.Call.Self;
251 Uninterpreted_Data :=
252 Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
253 else
254 -- Case of an aborted task
255
256 Uninterpreted_Data := System.Null_Address;
257 end if;
258 end if;
259
260 -- Self_Id.Common.Call should already be updated by the Caller
261 -- On return, we will start the rendezvous.
262
263 STPO.Unlock (Self_Id);
264
265 if Single_Lock then
266 Unlock_RTS;
267 end if;
268
269 Initialization.Undefer_Abort (Self_Id);
270
271 if Parameters.Runtime_Traces then
272 Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
273 end if;
274 end Accept_Call;
275
276 --------------------
277 -- Accept_Trivial --
278 --------------------
279
280 procedure Accept_Trivial (E : Task_Entry_Index) is
281 Self_Id : constant Task_Id := STPO.Self;
282 Caller : Task_Id := null;
283 Open_Accepts : aliased Accept_List (1 .. 1);
284 Entry_Call : Entry_Call_Link;
285
286 begin
287 Initialization.Defer_Abort_Nestable (Self_Id);
288
289 if Single_Lock then
290 Lock_RTS;
291 end if;
292
293 STPO.Write_Lock (Self_Id);
294
295 if not Self_Id.Callable then
296 pragma Assert (Self_Id.Pending_ATC_Level = 0);
297
298 pragma Assert (Self_Id.Pending_Action);
299
300 STPO.Unlock (Self_Id);
301
302 if Single_Lock then
303 Unlock_RTS;
304 end if;
305
306 Initialization.Undefer_Abort_Nestable (Self_Id);
307
308 -- Should never get here ???
309
310 pragma Assert (False);
311 raise Standard'Abort_Signal;
312 end if;
313
314 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
315
316 if Entry_Call = null then
317 -- Need to wait for entry call
318
319 Open_Accepts (1).Null_Body := True;
320 Open_Accepts (1).S := E;
321 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
322
323 if Parameters.Runtime_Traces then
324 Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
325 end if;
326
327 pragma Debug
328 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
329
330 Wait_For_Call (Self_Id);
331
332 pragma Assert (Self_Id.Open_Accepts = null);
333
334 -- No need to do anything special here for pending abort.
335 -- Abort_Signal will be raised by Undefer on exit.
336
337 STPO.Unlock (Self_Id);
338
339 else -- found caller already waiting
340 pragma Assert (Entry_Call.State < Done);
341
342 STPO.Unlock (Self_Id);
343 Caller := Entry_Call.Self;
344
345 STPO.Write_Lock (Caller);
346 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
347 STPO.Unlock (Caller);
348 end if;
349
350 if Parameters.Runtime_Traces then
351 Send_Trace_Info (M_Accept_Complete);
352
353 -- Fake one, since there is (???) no way
354 -- to know that the rendezvous is over
355
356 Send_Trace_Info (M_RDV_Complete);
357 end if;
358
359 if Single_Lock then
360 Unlock_RTS;
361 end if;
362
363 Initialization.Undefer_Abort_Nestable (Self_Id);
364 end Accept_Trivial;
365
366 --------------------
367 -- Boost_Priority --
368 --------------------
369
370 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
371 Caller : constant Task_Id := Call.Self;
372 Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
373 Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
374
375 begin
376 if Caller_Prio > Acceptor_Prio then
377 Call.Acceptor_Prev_Priority := Acceptor_Prio;
378 Set_Priority (Acceptor, Caller_Prio);
379
380 else
381 Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
382 end if;
383 end Boost_Priority;
384
385 -----------------
386 -- Call_Simple --
387 -----------------
388
389 procedure Call_Simple
390 (Acceptor : Task_Id;
391 E : Task_Entry_Index;
392 Uninterpreted_Data : System.Address)
393 is
394 Rendezvous_Successful : Boolean;
395 pragma Unreferenced (Rendezvous_Successful);
396
397 begin
398 -- If pragma Detect_Blocking is active then Program_Error must be
399 -- raised if this potentially blocking operation is called from a
400 -- protected action.
401
402 if System.Tasking.Detect_Blocking
403 and then STPO.Self.Common.Protected_Action_Nesting > 0
404 then
405 Ada.Exceptions.Raise_Exception
406 (Program_Error'Identity, "potentially blocking operation");
407 end if;
408
409 Call_Synchronous
410 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
411 end Call_Simple;
412
413 ----------------------
414 -- Call_Synchronous --
415 ----------------------
416
417 procedure Call_Synchronous
418 (Acceptor : Task_Id;
419 E : Task_Entry_Index;
420 Uninterpreted_Data : System.Address;
421 Mode : Call_Modes;
422 Rendezvous_Successful : out Boolean)
423 is
424 Self_Id : constant Task_Id := STPO.Self;
425 Level : ATC_Level;
426 Entry_Call : Entry_Call_Link;
427
428 begin
429 pragma Assert (Mode /= Asynchronous_Call);
430
431 Local_Defer_Abort (Self_Id);
432 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
433 pragma Debug
434 (Debug.Trace (Self_Id, "CS: entered ATC level: " &
435 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
436 Level := Self_Id.ATC_Nesting_Level;
437 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
438 Entry_Call.Next := null;
439 Entry_Call.Mode := Mode;
440 Entry_Call.Cancellation_Attempted := False;
441
442 if Parameters.Runtime_Traces then
443 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
444 end if;
445
446 -- If this is a call made inside of an abort deferred region,
447 -- the call should be never abortable.
448
449 if Self_Id.Deferral_Level > 1 then
450 Entry_Call.State := Never_Abortable;
451 else
452 Entry_Call.State := Now_Abortable;
453 end if;
454
455 Entry_Call.E := Entry_Index (E);
456 Entry_Call.Prio := Get_Priority (Self_Id);
457 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
458 Entry_Call.Called_Task := Acceptor;
459 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
460 Entry_Call.With_Abort := True;
461
462 -- Note: the caller will undefer abort on return (see WARNING above)
463
464 if Single_Lock then
465 Lock_RTS;
466 end if;
467
468 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
469 STPO.Write_Lock (Self_Id);
470 Utilities.Exit_One_ATC_Level (Self_Id);
471 STPO.Unlock (Self_Id);
472
473 if Single_Lock then
474 Unlock_RTS;
475 end if;
476
477 if Parameters.Runtime_Traces then
478 Send_Trace_Info (E_Missed, Acceptor);
479 end if;
480
481 Local_Undefer_Abort (Self_Id);
482 raise Tasking_Error;
483 end if;
484
485 STPO.Write_Lock (Self_Id);
486 pragma Debug
487 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
488 Entry_Calls.Wait_For_Completion (Entry_Call);
489 pragma Debug
490 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
491 Rendezvous_Successful := Entry_Call.State = Done;
492 STPO.Unlock (Self_Id);
493
494 if Single_Lock then
495 Unlock_RTS;
496 end if;
497
498 Local_Undefer_Abort (Self_Id);
499 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
500 end Call_Synchronous;
501
502 --------------
503 -- Callable --
504 --------------
505
506 function Callable (T : Task_Id) return Boolean is
507 Result : Boolean;
508 Self_Id : constant Task_Id := STPO.Self;
509
510 begin
511 Initialization.Defer_Abort_Nestable (Self_Id);
512
513 if Single_Lock then
514 Lock_RTS;
515 end if;
516
517 STPO.Write_Lock (T);
518 Result := T.Callable;
519 STPO.Unlock (T);
520
521 if Single_Lock then
522 Unlock_RTS;
523 end if;
524
525 Initialization.Undefer_Abort_Nestable (Self_Id);
526 return Result;
527 end Callable;
528
529 ----------------------------
530 -- Cancel_Task_Entry_Call --
531 ----------------------------
532
533 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
534 begin
535 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
536 end Cancel_Task_Entry_Call;
537
538 -------------------------
539 -- Complete_Rendezvous --
540 -------------------------
541
542 procedure Complete_Rendezvous is
543 begin
544 Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
545 end Complete_Rendezvous;
546
547 -------------------------------------
548 -- Exceptional_Complete_Rendezvous --
549 -------------------------------------
550
551 procedure Exceptional_Complete_Rendezvous
552 (Ex : Ada.Exceptions.Exception_Id)
553 is
554 Self_Id : constant Task_Id := STPO.Self;
555 Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
556 Caller : Task_Id;
557 Called_PO : STPE.Protection_Entries_Access;
558 Acceptor_Prev_Priority : Integer;
559
560 Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
561 Ceiling_Violation : Boolean;
562
563 use type Ada.Exceptions.Exception_Id;
564 procedure Internal_Reraise;
565 pragma Import (C, Internal_Reraise, "__gnat_reraise");
566
567 procedure Transfer_Occurrence
568 (Target : Ada.Exceptions.Exception_Occurrence_Access;
569 Source : Ada.Exceptions.Exception_Occurrence);
570 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
571
572 use type STPE.Protection_Entries_Access;
573
574 begin
575 -- Consider phasing out Complete_Rendezvous in favor
576 -- of direct call to this with Ada.Exceptions.Null_ID.
577 -- See code expansion examples for Accept_Call and Selective_Wait.
578 -- Also consider putting an explicit re-raise after this call, in
579 -- the generated code. That way we could eliminate the
580 -- code here that reraises the exception.
581
582 -- The deferral level is critical here,
583 -- since we want to raise an exception or allow abort to take
584 -- place, if there is an exception or abort pending.
585
586 pragma Debug
587 (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
588
589 if Ex = Ada.Exceptions.Null_Id then
590 -- The call came from normal end-of-rendezvous,
591 -- so abort is not yet deferred.
592
593 if Parameters.Runtime_Traces then
594 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
595 end if;
596
597 Initialization.Defer_Abort_Nestable (Self_Id);
598 end if;
599
600 -- We need to clean up any accepts which Self may have
601 -- been serving when it was aborted.
602
603 if Ex = Standard'Abort_Signal'Identity then
604 if Single_Lock then
605 Lock_RTS;
606 end if;
607
608 while Entry_Call /= null loop
609 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
610
611 -- All forms of accept make sure that the acceptor is not
612 -- completed, before accepting further calls, so that we
613 -- can be sure that no further calls are made after the
614 -- current calls are purged.
615
616 Caller := Entry_Call.Self;
617
618 -- Take write lock. This follows the lock precedence rule that
619 -- Caller may be locked while holding lock of Acceptor.
620 -- Complete the call abnormally, with exception.
621
622 STPO.Write_Lock (Caller);
623 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
624 STPO.Unlock (Caller);
625 Entry_Call := Entry_Call.Acceptor_Prev_Call;
626 end loop;
627
628 if Single_Lock then
629 Unlock_RTS;
630 end if;
631
632 else
633 Caller := Entry_Call.Self;
634
635 if Entry_Call.Needs_Requeue then
636 -- We dare not lock Self_Id at the same time as Caller,
637 -- for fear of deadlock.
638
639 Entry_Call.Needs_Requeue := False;
640 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
641
642 if Entry_Call.Called_Task /= null then
643 -- Requeue to another task entry
644
645 if Single_Lock then
646 Lock_RTS;
647 end if;
648
649 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
650 if Single_Lock then
651 Unlock_RTS;
652 end if;
653
654 Initialization.Undefer_Abort (Self_Id);
655 raise Tasking_Error;
656 end if;
657
658 if Single_Lock then
659 Unlock_RTS;
660 end if;
661
662 else
663 -- Requeue to a protected entry
664
665 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
666 STPE.Lock_Entries (Called_PO, Ceiling_Violation);
667
668 if Ceiling_Violation then
669 pragma Assert (Ex = Ada.Exceptions.Null_Id);
670
671 Exception_To_Raise := Program_Error'Identity;
672 Entry_Call.Exception_To_Raise := Exception_To_Raise;
673
674 if Single_Lock then
675 Lock_RTS;
676 end if;
677
678 STPO.Write_Lock (Caller);
679 Initialization.Wakeup_Entry_Caller
680 (Self_Id, Entry_Call, Done);
681 STPO.Unlock (Caller);
682
683 if Single_Lock then
684 Unlock_RTS;
685 end if;
686
687 else
688 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
689 POO.PO_Service_Entries (Self_Id, Called_PO);
690 end if;
691 end if;
692
693 Entry_Calls.Reset_Priority
694 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
695
696 else
697 -- The call does not need to be requeued
698
699 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
700 Entry_Call.Exception_To_Raise := Ex;
701
702 if Single_Lock then
703 Lock_RTS;
704 end if;
705
706 STPO.Write_Lock (Caller);
707
708 -- Done with Caller locked to make sure that Wakeup is not lost
709
710 if Ex /= Ada.Exceptions.Null_Id then
711 Transfer_Occurrence
712 (Caller.Common.Compiler_Data.Current_Excep'Access,
713 Self_Id.Common.Compiler_Data.Current_Excep);
714 end if;
715
716 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
717 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
718
719 STPO.Unlock (Caller);
720
721 if Single_Lock then
722 Unlock_RTS;
723 end if;
724
725 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
726 end if;
727 end if;
728
729 Initialization.Undefer_Abort (Self_Id);
730
731 if Exception_To_Raise /= Ada.Exceptions.Null_Id then
732 Internal_Reraise;
733 end if;
734
735 -- ??? Do we need to give precedence to Program_Error that might be
736 -- raised due to failure of finalization, over Tasking_Error from
737 -- failure of requeue?
738 end Exceptional_Complete_Rendezvous;
739
740 -------------------------------------
741 -- Requeue_Protected_To_Task_Entry --
742 -------------------------------------
743
744 procedure Requeue_Protected_To_Task_Entry
745 (Object : STPE.Protection_Entries_Access;
746 Acceptor : Task_Id;
747 E : Task_Entry_Index;
748 With_Abort : Boolean)
749 is
750 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
751 begin
752 pragma Assert (STPO.Self.Deferral_Level > 0);
753
754 Entry_Call.E := Entry_Index (E);
755 Entry_Call.Called_Task := Acceptor;
756 Entry_Call.Called_PO := Null_Address;
757 Entry_Call.With_Abort := With_Abort;
758 Object.Call_In_Progress := null;
759 end Requeue_Protected_To_Task_Entry;
760
761 ------------------------
762 -- Requeue_Task_Entry --
763 ------------------------
764
765 procedure Requeue_Task_Entry
766 (Acceptor : Task_Id;
767 E : Task_Entry_Index;
768 With_Abort : Boolean)
769 is
770 Self_Id : constant Task_Id := STPO.Self;
771 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
772
773 begin
774 Initialization.Defer_Abort (Self_Id);
775 Entry_Call.Needs_Requeue := True;
776 Entry_Call.With_Abort := With_Abort;
777 Entry_Call.E := Entry_Index (E);
778 Entry_Call.Called_Task := Acceptor;
779 Initialization.Undefer_Abort (Self_Id);
780 end Requeue_Task_Entry;
781
782 --------------------
783 -- Selective_Wait --
784 --------------------
785
786 procedure Selective_Wait
787 (Open_Accepts : Accept_List_Access;
788 Select_Mode : Select_Modes;
789 Uninterpreted_Data : out System.Address;
790 Index : out Select_Index)
791 is
792 Self_Id : constant Task_Id := STPO.Self;
793 Entry_Call : Entry_Call_Link;
794 Treatment : Select_Treatment;
795 Caller : Task_Id;
796 Selection : Select_Index;
797 Open_Alternative : Boolean;
798
799 begin
800 Initialization.Defer_Abort (Self_Id);
801
802 if Single_Lock then
803 Lock_RTS;
804 end if;
805
806 STPO.Write_Lock (Self_Id);
807
808 if not Self_Id.Callable then
809 pragma Assert (Self_Id.Pending_ATC_Level = 0);
810
811 pragma Assert (Self_Id.Pending_Action);
812
813 STPO.Unlock (Self_Id);
814
815 if Single_Lock then
816 Unlock_RTS;
817 end if;
818
819 -- ??? In some cases abort is deferred more than once. Need to
820 -- figure out why this happens.
821
822 if Self_Id.Deferral_Level > 1 then
823 Self_Id.Deferral_Level := 1;
824 end if;
825
826 Initialization.Undefer_Abort (Self_Id);
827
828 -- Should never get here ???
829
830 pragma Assert (False);
831 raise Standard'Abort_Signal;
832 end if;
833
834 pragma Assert (Open_Accepts /= null);
835
836 Uninterpreted_Data := Null_Address;
837
838 Queuing.Select_Task_Entry_Call
839 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
840
841 -- Determine the kind and disposition of the select
842
843 Treatment := Default_Treatment (Select_Mode);
844 Self_Id.Chosen_Index := No_Rendezvous;
845
846 if Open_Alternative then
847 if Entry_Call /= null then
848 if Open_Accepts (Selection).Null_Body then
849 Treatment := Accept_Alternative_Completed;
850 else
851 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
852 Treatment := Accept_Alternative_Selected;
853 end if;
854
855 Self_Id.Chosen_Index := Selection;
856
857 elsif Treatment = No_Alternative_Open then
858 Treatment := Accept_Alternative_Open;
859 end if;
860 end if;
861
862 -- Handle the select according to the disposition selected above
863
864 case Treatment is
865 when Accept_Alternative_Selected =>
866 -- Ready to rendezvous
867
868 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
869
870 -- In this case the accept body is not Null_Body. Defer abort
871 -- until it gets into the accept body.
872
873 pragma Assert (Self_Id.Deferral_Level = 1);
874
875 Initialization.Defer_Abort_Nestable (Self_Id);
876 STPO.Unlock (Self_Id);
877
878 when Accept_Alternative_Completed =>
879
880 -- Accept body is null, so rendezvous is over immediately
881
882 if Parameters.Runtime_Traces then
883 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
884 end if;
885
886 STPO.Unlock (Self_Id);
887 Caller := Entry_Call.Self;
888
889 STPO.Write_Lock (Caller);
890 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
891 STPO.Unlock (Caller);
892
893 when Accept_Alternative_Open =>
894
895 -- Wait for caller
896
897 Self_Id.Open_Accepts := Open_Accepts;
898 pragma Debug
899 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
900
901 if Parameters.Runtime_Traces then
902 Send_Trace_Info (W_Select, Self_Id,
903 Integer (Open_Accepts'Length));
904 end if;
905
906 Wait_For_Call (Self_Id);
907
908 pragma Assert (Self_Id.Open_Accepts = null);
909
910 -- Self_Id.Common.Call should already be updated by the Caller if
911 -- not aborted. It might also be ready to do rendezvous even if
912 -- this wakes up due to an abort. Therefore, if the call is not
913 -- empty we need to do the rendezvous if the accept body is not
914 -- Null_Body.
915
916 -- Aren't the first two conditions below redundant???
917
918 if Self_Id.Chosen_Index /= No_Rendezvous
919 and then Self_Id.Common.Call /= null
920 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
921 then
922 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
923
924 pragma Assert
925 (Self_Id.Deferral_Level = 1
926 or else
927 (Self_Id.Deferral_Level = 0
928 and then not Restrictions.Abort_Allowed));
929
930 Initialization.Defer_Abort_Nestable (Self_Id);
931
932 -- Leave abort deferred until the accept body
933 end if;
934
935 STPO.Unlock (Self_Id);
936
937 when Else_Selected =>
938 pragma Assert (Self_Id.Open_Accepts = null);
939
940 if Parameters.Runtime_Traces then
941 Send_Trace_Info (M_Select_Else);
942 end if;
943
944 STPO.Unlock (Self_Id);
945
946 when Terminate_Selected =>
947 -- Terminate alternative is open
948
949 Self_Id.Open_Accepts := Open_Accepts;
950 Self_Id.Common.State := Acceptor_Sleep;
951
952 -- Notify ancestors that this task is on a terminate alternative
953
954 STPO.Unlock (Self_Id);
955 Utilities.Make_Passive (Self_Id, Task_Completed => False);
956 STPO.Write_Lock (Self_Id);
957
958 -- Wait for normal entry call or termination
959
960 Wait_For_Call (Self_Id);
961
962 pragma Assert (Self_Id.Open_Accepts = null);
963
964 if Self_Id.Terminate_Alternative then
965 -- An entry call should have reset this to False,
966 -- so we must be aborted.
967 -- We cannot be in an async. select, since that
968 -- is not legal, so the abort must be of the entire
969 -- task. Therefore, we do not need to cancel the
970 -- terminate alternative. The cleanup will be done
971 -- in Complete_Master.
972
973 pragma Assert (Self_Id.Pending_ATC_Level = 0);
974 pragma Assert (Self_Id.Awake_Count = 0);
975
976 STPO.Unlock (Self_Id);
977
978 if Single_Lock then
979 Unlock_RTS;
980 end if;
981
982 Index := Self_Id.Chosen_Index;
983 Initialization.Undefer_Abort_Nestable (Self_Id);
984
985 if Self_Id.Pending_Action then
986 Initialization.Do_Pending_Action (Self_Id);
987 end if;
988
989 return;
990
991 else
992 -- Self_Id.Common.Call and Self_Id.Chosen_Index
993 -- should already be updated by the Caller.
994
995 if Self_Id.Chosen_Index /= No_Rendezvous
996 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
997 then
998 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
999
1000 pragma Assert (Self_Id.Deferral_Level = 1);
1001
1002 -- We need an extra defer here, to keep abort
1003 -- deferred until we get into the accept body
1004
1005 Initialization.Defer_Abort_Nestable (Self_Id);
1006 end if;
1007 end if;
1008
1009 STPO.Unlock (Self_Id);
1010
1011 when No_Alternative_Open =>
1012 -- In this case, Index will be No_Rendezvous on return, which
1013 -- should cause a Program_Error if it is not a Delay_Mode.
1014
1015 -- If delay alternative exists (Delay_Mode) we should suspend
1016 -- until the delay expires.
1017
1018 Self_Id.Open_Accepts := null;
1019
1020 if Select_Mode = Delay_Mode then
1021 Self_Id.Common.State := Delay_Sleep;
1022
1023 loop
1024 exit when
1025 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1026 Sleep (Self_Id, Delay_Sleep);
1027 end loop;
1028
1029 Self_Id.Common.State := Runnable;
1030 STPO.Unlock (Self_Id);
1031
1032 else
1033 STPO.Unlock (Self_Id);
1034
1035 if Single_Lock then
1036 Unlock_RTS;
1037 end if;
1038
1039 Initialization.Undefer_Abort (Self_Id);
1040 Ada.Exceptions.Raise_Exception
1041 (Program_Error'Identity, "Entry call not a delay mode");
1042 end if;
1043 end case;
1044
1045 if Single_Lock then
1046 Unlock_RTS;
1047 end if;
1048
1049 -- Caller has been chosen.
1050 -- Self_Id.Common.Call should already be updated by the Caller.
1051 -- Self_Id.Chosen_Index should either be updated by the Caller
1052 -- or by Test_Selective_Wait.
1053 -- On return, we sill start rendezvous unless the accept body is
1054 -- null. In the latter case, we will have already completed the RV.
1055
1056 Index := Self_Id.Chosen_Index;
1057 Initialization.Undefer_Abort_Nestable (Self_Id);
1058 end Selective_Wait;
1059
1060 ------------------------------------
1061 -- Setup_For_Rendezvous_With_Body --
1062 ------------------------------------
1063
1064 procedure Setup_For_Rendezvous_With_Body
1065 (Entry_Call : Entry_Call_Link;
1066 Acceptor : Task_Id) is
1067 begin
1068 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1069 Acceptor.Common.Call := Entry_Call;
1070
1071 if Entry_Call.State = Now_Abortable then
1072 Entry_Call.State := Was_Abortable;
1073 end if;
1074
1075 Boost_Priority (Entry_Call, Acceptor);
1076 end Setup_For_Rendezvous_With_Body;
1077
1078 ----------------
1079 -- Task_Count --
1080 ----------------
1081
1082 function Task_Count (E : Task_Entry_Index) return Natural is
1083 Self_Id : constant Task_Id := STPO.Self;
1084 Return_Count : Natural;
1085
1086 begin
1087 Initialization.Defer_Abort (Self_Id);
1088
1089 if Single_Lock then
1090 Lock_RTS;
1091 end if;
1092
1093 STPO.Write_Lock (Self_Id);
1094 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1095 STPO.Unlock (Self_Id);
1096
1097 if Single_Lock then
1098 Unlock_RTS;
1099 end if;
1100
1101 Initialization.Undefer_Abort (Self_Id);
1102
1103 -- Call Yield to let other tasks get a chance to run as this is a
1104 -- potential dispatching point.
1105
1106 Yield (Do_Yield => False);
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) return Boolean
1117 is
1118 E : constant Task_Entry_Index :=
1119 Task_Entry_Index (Entry_Call.E);
1120 Old_State : constant Entry_Call_State := Entry_Call.State;
1121 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1122 Parent : constant Task_Id := Acceptor.Common.Parent;
1123 Parent_Locked : Boolean := False;
1124 Null_Body : Boolean;
1125
1126 begin
1127 -- Find out whether Entry_Call can be accepted immediately
1128
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 Entry_Call.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 :=
1282 New_State (Entry_Call.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 pragma Detect_Blocking is active then Program_Error must be
1348 -- raised if this potentially blocking operation is called from a
1349 -- protected action.
1350
1351 if System.Tasking.Detect_Blocking
1352 and then Self_Id.Common.Protected_Action_Nesting > 0
1353 then
1354 Ada.Exceptions.Raise_Exception
1355 (Program_Error'Identity, "potentially blocking operation");
1356 end if;
1357
1358 if Parameters.Runtime_Traces then
1359 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1360 end if;
1361
1362 if Mode = Simple_Call or else Mode = Conditional_Call then
1363 Call_Synchronous
1364 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1365
1366 else
1367 -- This is an asynchronous call
1368
1369 -- Abort must already be deferred by the compiler-generated code.
1370 -- Without this, an abort that occurs between the time that this
1371 -- call is made and the time that the abortable part's cleanup
1372 -- handler is set up might miss the cleanup handler and leave the
1373 -- call pending.
1374
1375 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1376 pragma Debug
1377 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1378 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1379 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1380 Entry_Call.Next := null;
1381 Entry_Call.Mode := Mode;
1382 Entry_Call.Cancellation_Attempted := False;
1383 Entry_Call.State := Not_Yet_Abortable;
1384 Entry_Call.E := Entry_Index (E);
1385 Entry_Call.Prio := Get_Priority (Self_Id);
1386 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1387 Entry_Call.Called_Task := Acceptor;
1388 Entry_Call.Called_PO := Null_Address;
1389 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1390 Entry_Call.With_Abort := True;
1391
1392 if Single_Lock then
1393 Lock_RTS;
1394 end if;
1395
1396 if not Task_Do_Or_Queue (Self_Id, Entry_Call) 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 Self_Id.Common.State := Acceptor_Sleep;
1572
1573 -- Try to remove calls to Sleep in the loop below by letting the
1574 -- caller a chance of getting ready immediately, using Unlock
1575 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1576
1577 if Single_Lock then
1578 Unlock_RTS;
1579 else
1580 Unlock (Self_Id);
1581 end if;
1582
1583 if Self_Id.Open_Accepts /= null then
1584 Yield;
1585 end if;
1586
1587 if Single_Lock then
1588 Lock_RTS;
1589 else
1590 Write_Lock (Self_Id);
1591 end if;
1592
1593 -- Check if this task has been aborted while the lock was released
1594
1595 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1596 Self_Id.Open_Accepts := null;
1597 end if;
1598
1599 loop
1600 exit when Self_Id.Open_Accepts = null;
1601
1602 if Timedout then
1603 Sleep (Self_Id, Acceptor_Sleep);
1604 else
1605 if Parameters.Runtime_Traces then
1606 Send_Trace_Info (WT_Select,
1607 Self_Id,
1608 Integer (Open_Accepts'Length),
1609 Timeout);
1610 end if;
1611
1612 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1613 Acceptor_Sleep, Timedout, Yielded);
1614 end if;
1615
1616 if Timedout then
1617 Self_Id.Open_Accepts := null;
1618
1619 if Parameters.Runtime_Traces then
1620 Send_Trace_Info (E_Timeout);
1621 end if;
1622 end if;
1623 end loop;
1624
1625 Self_Id.Common.State := Runnable;
1626
1627 -- Self_Id.Common.Call should already be updated by the Caller if
1628 -- not aborted. It might also be ready to do rendezvous even if
1629 -- this wakes up due to an abort. Therefore, if the call is not
1630 -- empty we need to do the rendezvous if the accept body is not
1631 -- Null_Body.
1632
1633 if Self_Id.Chosen_Index /= No_Rendezvous
1634 and then Self_Id.Common.Call /= null
1635 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1636 then
1637 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1638
1639 pragma Assert (Self_Id.Deferral_Level = 1);
1640
1641 Initialization.Defer_Abort_Nestable (Self_Id);
1642
1643 -- Leave abort deferred until the accept body
1644 end if;
1645
1646 STPO.Unlock (Self_Id);
1647
1648 when No_Alternative_Open =>
1649 -- In this case, Index will be No_Rendezvous on return. We sleep
1650 -- for the time we need to.
1651 -- Wait for a signal or timeout. A wakeup can be made
1652 -- for several reasons:
1653 -- 1) Delay is expired
1654 -- 2) Pending_Action needs to be checked
1655 -- (Abort, Priority change)
1656 -- 3) Spurious wakeup
1657
1658 Self_Id.Open_Accepts := null;
1659 Self_Id.Common.State := Acceptor_Sleep;
1660
1661 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1662 Timedout, Yielded);
1663
1664 Self_Id.Common.State := Runnable;
1665
1666 STPO.Unlock (Self_Id);
1667
1668 when others =>
1669 -- Should never get here
1670 pragma Assert (False);
1671 null;
1672 end case;
1673
1674 if Single_Lock then
1675 Unlock_RTS;
1676 end if;
1677
1678 if not Yielded then
1679 Yield;
1680 end if;
1681
1682 -- Caller has been chosen
1683
1684 -- Self_Id.Common.Call should already be updated by the Caller
1685
1686 -- Self_Id.Chosen_Index should either be updated by the Caller
1687 -- or by Test_Selective_Wait
1688
1689 Index := Self_Id.Chosen_Index;
1690 Initialization.Undefer_Abort_Nestable (Self_Id);
1691
1692 -- Start rendezvous, if not already completed
1693 end Timed_Selective_Wait;
1694
1695 ---------------------------
1696 -- Timed_Task_Entry_Call --
1697 ---------------------------
1698
1699 procedure Timed_Task_Entry_Call
1700 (Acceptor : Task_Id;
1701 E : Task_Entry_Index;
1702 Uninterpreted_Data : System.Address;
1703 Timeout : Duration;
1704 Mode : Delay_Modes;
1705 Rendezvous_Successful : out Boolean)
1706 is
1707 Self_Id : constant Task_Id := STPO.Self;
1708 Level : ATC_Level;
1709 Entry_Call : Entry_Call_Link;
1710
1711 Yielded : Boolean;
1712 pragma Unreferenced (Yielded);
1713
1714 begin
1715 -- If pragma Detect_Blocking is active then Program_Error must be
1716 -- raised if this potentially blocking operation is called from a
1717 -- protected action.
1718
1719 if System.Tasking.Detect_Blocking
1720 and then Self_Id.Common.Protected_Action_Nesting > 0
1721 then
1722 Ada.Exceptions.Raise_Exception
1723 (Program_Error'Identity, "potentially blocking operation");
1724 end if;
1725
1726 Initialization.Defer_Abort (Self_Id);
1727 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1728
1729 pragma Debug
1730 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1731 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1732
1733 if Parameters.Runtime_Traces then
1734 Send_Trace_Info (WT_Call, Acceptor,
1735 Entry_Index (E), Timeout);
1736 end if;
1737
1738 Level := Self_Id.ATC_Nesting_Level;
1739 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1740 Entry_Call.Next := null;
1741 Entry_Call.Mode := Timed_Call;
1742 Entry_Call.Cancellation_Attempted := False;
1743
1744 -- If this is a call made inside of an abort deferred region,
1745 -- the call should be never abortable.
1746
1747 if Self_Id.Deferral_Level > 1 then
1748 Entry_Call.State := Never_Abortable;
1749 else
1750 Entry_Call.State := Now_Abortable;
1751 end if;
1752
1753 Entry_Call.E := Entry_Index (E);
1754 Entry_Call.Prio := Get_Priority (Self_Id);
1755 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1756 Entry_Call.Called_Task := Acceptor;
1757 Entry_Call.Called_PO := Null_Address;
1758 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1759 Entry_Call.With_Abort := True;
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 (Self_Id, Entry_Call) then
1768 STPO.Write_Lock (Self_Id);
1769 Utilities.Exit_One_ATC_Level (Self_Id);
1770 STPO.Unlock (Self_Id);
1771
1772 if Single_Lock then
1773 Unlock_RTS;
1774 end if;
1775
1776 Initialization.Undefer_Abort (Self_Id);
1777
1778 if Parameters.Runtime_Traces then
1779 Send_Trace_Info (E_Missed, Acceptor);
1780 end if;
1781 raise Tasking_Error;
1782 end if;
1783
1784 Write_Lock (Self_Id);
1785 Entry_Calls.Wait_For_Completion_With_Timeout
1786 (Entry_Call, Timeout, Mode, Yielded);
1787 Unlock (Self_Id);
1788
1789 if Single_Lock then
1790 Unlock_RTS;
1791 end if;
1792
1793 -- ??? Do we need to yield in case Yielded is False
1794
1795 Rendezvous_Successful := Entry_Call.State = Done;
1796 Initialization.Undefer_Abort (Self_Id);
1797 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1798 end Timed_Task_Entry_Call;
1799
1800 -------------------
1801 -- Wait_For_Call --
1802 -------------------
1803
1804 procedure Wait_For_Call (Self_Id : Task_Id) is
1805 begin
1806 Self_Id.Common.State := Acceptor_Sleep;
1807
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 & Timed_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 loop
1835 exit when Self_Id.Open_Accepts = null;
1836 Sleep (Self_Id, Acceptor_Sleep);
1837 end loop;
1838
1839 Self_Id.Common.State := Runnable;
1840 end Wait_For_Call;
1841
1842 end System.Tasking.Rendezvous;
Mirror of the offical gcc git repository hosted at gcc.gnu.org