?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2005-05-11 Kenneth Zadeck <zadeck@naturalbridge.com>
[official-gcc.git] / gcc / ada / s-tasren.adb
blob6bdd8d27738173ebebf08f2a201a923f1f8c92c9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G . R E N D E Z V O U S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 with Ada.Exceptions;
35 -- Used for Exception_ID
36 -- Null_Id
37 -- Transfer_Occurrence
38 -- Raise_Exception
39
40 with System.Task_Primitives.Operations;
41 -- used for Get_Priority
42 -- Set_Priority
43 -- Write_Lock
44 -- Unlock
45 -- Sleep
46 -- Wakeup
47 -- Timed_Sleep
48
49 with System.Tasking.Entry_Calls;
50 -- Used for Wait_For_Completion
51 -- Wait_For_Completion_With_Timeout
52 -- Wait_Until_Abortable
53
54 with System.Tasking.Initialization;
55 -- used for Defer_Abort
56 -- Undefer_Abort
57 -- Poll_Base_Priority_Change
58 -- 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
563 Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
564 Ceiling_Violation : Boolean;
565
566 use type Ada.Exceptions.Exception_Id;
567 procedure Internal_Reraise;
568 pragma Import (C, Internal_Reraise, "__gnat_reraise");
569
570 procedure Transfer_Occurrence
571 (Target : Ada.Exceptions.Exception_Occurrence_Access;
572 Source : Ada.Exceptions.Exception_Occurrence);
573 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
574
575 use type STPE.Protection_Entries_Access;
576
577 begin
578 -- Consider phasing out Complete_Rendezvous in favor
579 -- of direct call to this with Ada.Exceptions.Null_ID.
580 -- See code expansion examples for Accept_Call and Selective_Wait.
581 -- Also consider putting an explicit re-raise after this call, in
582 -- the generated code. That way we could eliminate the
583 -- code here that reraises the exception.
584
585 -- The deferral level is critical here,
586 -- since we want to raise an exception or allow abort to take
587 -- place, if there is an exception or abort pending.
588
589 pragma Debug
590 (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
591
592 if Ex = Ada.Exceptions.Null_Id then
593 -- The call came from normal end-of-rendezvous,
594 -- so abort is not yet deferred.
595
596 if Parameters.Runtime_Traces then
597 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
598 end if;
599
600 Initialization.Defer_Abort_Nestable (Self_Id);
601 end if;
602
603 -- We need to clean up any accepts which Self may have
604 -- been serving when it was aborted.
605
606 if Ex = Standard'Abort_Signal'Identity then
607 if Single_Lock then
608 Lock_RTS;
609 end if;
610
611 while Entry_Call /= null loop
612 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
613
614 -- All forms of accept make sure that the acceptor is not
615 -- completed, before accepting further calls, so that we
616 -- can be sure that no further calls are made after the
617 -- current calls are purged.
618
619 Caller := Entry_Call.Self;
620
621 -- Take write lock. This follows the lock precedence rule that
622 -- Caller may be locked while holding lock of Acceptor.
623 -- Complete the call abnormally, with exception.
624
625 STPO.Write_Lock (Caller);
626 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
627 STPO.Unlock (Caller);
628 Entry_Call := Entry_Call.Acceptor_Prev_Call;
629 end loop;
630
631 if Single_Lock then
632 Unlock_RTS;
633 end if;
634
635 else
636 Caller := Entry_Call.Self;
637
638 if Entry_Call.Needs_Requeue then
639 -- We dare not lock Self_Id at the same time as Caller,
640 -- for fear of deadlock.
641
642 Entry_Call.Needs_Requeue := False;
643 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
644
645 if Entry_Call.Called_Task /= null then
646 -- Requeue to another task entry
647
648 if Single_Lock then
649 Lock_RTS;
650 end if;
651
652 if not Task_Do_Or_Queue
653 (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
654 then
655 if Single_Lock then
656 Unlock_RTS;
657 end if;
658
659 Initialization.Undefer_Abort (Self_Id);
660 raise Tasking_Error;
661 end if;
662
663 if Single_Lock then
664 Unlock_RTS;
665 end if;
666
667 else
668 -- Requeue to a protected entry
669
670 Called_PO := POE.To_Protection (Entry_Call.Called_PO);
671 STPE.Lock_Entries (Called_PO, Ceiling_Violation);
672
673 if Ceiling_Violation then
674 pragma Assert (Ex = Ada.Exceptions.Null_Id);
675
676 Exception_To_Raise := Program_Error'Identity;
677 Entry_Call.Exception_To_Raise := Exception_To_Raise;
678
679 if Single_Lock then
680 Lock_RTS;
681 end if;
682
683 STPO.Write_Lock (Caller);
684 Initialization.Wakeup_Entry_Caller
685 (Self_Id, Entry_Call, Done);
686 STPO.Unlock (Caller);
687
688 if Single_Lock then
689 Unlock_RTS;
690 end if;
691
692 else
693 POO.PO_Do_Or_Queue
694 (Self_Id, Called_PO, Entry_Call,
695 Entry_Call.Requeue_With_Abort);
696 POO.PO_Service_Entries (Self_Id, Called_PO);
697 end if;
698 end if;
699
700 Entry_Calls.Reset_Priority
701 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
702
703 else
704 -- The call does not need to be requeued
705
706 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
707 Entry_Call.Exception_To_Raise := Ex;
708
709 if Single_Lock then
710 Lock_RTS;
711 end if;
712
713 STPO.Write_Lock (Caller);
714
715 -- Done with Caller locked to make sure that Wakeup is not lost
716
717 if Ex /= Ada.Exceptions.Null_Id then
718 Transfer_Occurrence
719 (Caller.Common.Compiler_Data.Current_Excep'Access,
720 Self_Id.Common.Compiler_Data.Current_Excep);
721 end if;
722
723 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
724 STPO.Unlock (Caller);
725
726 if Single_Lock then
727 Unlock_RTS;
728 end if;
729
730 Entry_Calls.Reset_Priority
731 (Self_Id, Entry_Call.Acceptor_Prev_Priority);
732 end if;
733 end if;
734
735 Initialization.Undefer_Abort (Self_Id);
736
737 if Exception_To_Raise /= Ada.Exceptions.Null_Id then
738 Internal_Reraise;
739 end if;
740
741 -- ??? Do we need to give precedence to Program_Error that might be
742 -- raised due to failure of finalization, over Tasking_Error from
743 -- failure of requeue?
744 end Exceptional_Complete_Rendezvous;
745
746 -------------------------------------
747 -- Requeue_Protected_To_Task_Entry --
748 -------------------------------------
749
750 procedure Requeue_Protected_To_Task_Entry
751 (Object : STPE.Protection_Entries_Access;
752 Acceptor : Task_Id;
753 E : Task_Entry_Index;
754 With_Abort : Boolean)
755 is
756 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
757 begin
758 pragma Assert (STPO.Self.Deferral_Level > 0);
759
760 Entry_Call.E := Entry_Index (E);
761 Entry_Call.Called_Task := Acceptor;
762 Entry_Call.Called_PO := Null_Address;
763 Entry_Call.Requeue_With_Abort := With_Abort;
764 Object.Call_In_Progress := null;
765 end Requeue_Protected_To_Task_Entry;
766
767 ------------------------
768 -- Requeue_Task_Entry --
769 ------------------------
770
771 procedure Requeue_Task_Entry
772 (Acceptor : Task_Id;
773 E : Task_Entry_Index;
774 With_Abort : Boolean)
775 is
776 Self_Id : constant Task_Id := STPO.Self;
777 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
778
779 begin
780 Initialization.Defer_Abort (Self_Id);
781 Entry_Call.Needs_Requeue := True;
782 Entry_Call.Requeue_With_Abort := With_Abort;
783 Entry_Call.E := Entry_Index (E);
784 Entry_Call.Called_Task := Acceptor;
785 Initialization.Undefer_Abort (Self_Id);
786 end Requeue_Task_Entry;
787
788 --------------------
789 -- Selective_Wait --
790 --------------------
791
792 procedure Selective_Wait
793 (Open_Accepts : Accept_List_Access;
794 Select_Mode : Select_Modes;
795 Uninterpreted_Data : out System.Address;
796 Index : out Select_Index)
797 is
798 Self_Id : constant Task_Id := STPO.Self;
799 Entry_Call : Entry_Call_Link;
800 Treatment : Select_Treatment;
801 Caller : Task_Id;
802 Selection : Select_Index;
803 Open_Alternative : Boolean;
804
805 begin
806 Initialization.Defer_Abort (Self_Id);
807
808 if Single_Lock then
809 Lock_RTS;
810 end if;
811
812 STPO.Write_Lock (Self_Id);
813
814 if not Self_Id.Callable then
815 pragma Assert (Self_Id.Pending_ATC_Level = 0);
816
817 pragma Assert (Self_Id.Pending_Action);
818
819 STPO.Unlock (Self_Id);
820
821 if Single_Lock then
822 Unlock_RTS;
823 end if;
824
825 -- ??? In some cases abort is deferred more than once. Need to
826 -- figure out why this happens.
827
828 if Self_Id.Deferral_Level > 1 then
829 Self_Id.Deferral_Level := 1;
830 end if;
831
832 Initialization.Undefer_Abort (Self_Id);
833
834 -- Should never get here ???
835
836 pragma Assert (False);
837 raise Standard'Abort_Signal;
838 end if;
839
840 pragma Assert (Open_Accepts /= null);
841
842 Uninterpreted_Data := Null_Address;
843
844 Queuing.Select_Task_Entry_Call
845 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
846
847 -- Determine the kind and disposition of the select
848
849 Treatment := Default_Treatment (Select_Mode);
850 Self_Id.Chosen_Index := No_Rendezvous;
851
852 if Open_Alternative then
853 if Entry_Call /= null then
854 if Open_Accepts (Selection).Null_Body then
855 Treatment := Accept_Alternative_Completed;
856 else
857 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
858 Treatment := Accept_Alternative_Selected;
859 end if;
860
861 Self_Id.Chosen_Index := Selection;
862
863 elsif Treatment = No_Alternative_Open then
864 Treatment := Accept_Alternative_Open;
865 end if;
866 end if;
867
868 -- Handle the select according to the disposition selected above
869
870 case Treatment is
871 when Accept_Alternative_Selected =>
872 -- Ready to rendezvous
873
874 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
875
876 -- In this case the accept body is not Null_Body. Defer abort
877 -- until it gets into the accept body.
878
879 pragma Assert (Self_Id.Deferral_Level = 1);
880
881 Initialization.Defer_Abort_Nestable (Self_Id);
882 STPO.Unlock (Self_Id);
883
884 when Accept_Alternative_Completed =>
885
886 -- Accept body is null, so rendezvous is over immediately
887
888 if Parameters.Runtime_Traces then
889 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
890 end if;
891
892 STPO.Unlock (Self_Id);
893 Caller := Entry_Call.Self;
894
895 STPO.Write_Lock (Caller);
896 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
897 STPO.Unlock (Caller);
898
899 when Accept_Alternative_Open =>
900
901 -- Wait for caller
902
903 Self_Id.Open_Accepts := Open_Accepts;
904 pragma Debug
905 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
906
907 if Parameters.Runtime_Traces then
908 Send_Trace_Info (W_Select, Self_Id,
909 Integer (Open_Accepts'Length));
910 end if;
911
912 Wait_For_Call (Self_Id);
913
914 pragma Assert (Self_Id.Open_Accepts = null);
915
916 -- Self_Id.Common.Call should already be updated by the Caller if
917 -- not aborted. It might also be ready to do rendezvous even if
918 -- this wakes up due to an abort. Therefore, if the call is not
919 -- empty we need to do the rendezvous if the accept body is not
920 -- Null_Body.
921
922 -- Aren't the first two conditions below redundant???
923
924 if Self_Id.Chosen_Index /= No_Rendezvous
925 and then Self_Id.Common.Call /= null
926 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
927 then
928 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
929
930 pragma Assert (Self_Id.Deferral_Level = 1);
931
932 Initialization.Defer_Abort_Nestable (Self_Id);
933
934 -- Leave abort deferred until the accept body
935 end if;
936
937 STPO.Unlock (Self_Id);
938
939 when Else_Selected =>
940 pragma Assert (Self_Id.Open_Accepts = null);
941
942 if Parameters.Runtime_Traces then
943 Send_Trace_Info (M_Select_Else);
944 end if;
945
946 STPO.Unlock (Self_Id);
947
948 when Terminate_Selected =>
949 -- Terminate alternative is open
950
951 Self_Id.Open_Accepts := Open_Accepts;
952 Self_Id.Common.State := Acceptor_Sleep;
953
954 -- Notify ancestors that this task is on a terminate alternative
955
956 STPO.Unlock (Self_Id);
957 Utilities.Make_Passive (Self_Id, Task_Completed => False);
958 STPO.Write_Lock (Self_Id);
959
960 -- Wait for normal entry call or termination
961
962 Wait_For_Call (Self_Id);
963
964 pragma Assert (Self_Id.Open_Accepts = null);
965
966 if Self_Id.Terminate_Alternative then
967 -- An entry call should have reset this to False,
968 -- so we must be aborted.
969 -- We cannot be in an async. select, since that
970 -- is not legal, so the abort must be of the entire
971 -- task. Therefore, we do not need to cancel the
972 -- terminate alternative. The cleanup will be done
973 -- in Complete_Master.
974
975 pragma Assert (Self_Id.Pending_ATC_Level = 0);
976 pragma Assert (Self_Id.Awake_Count = 0);
977
978 STPO.Unlock (Self_Id);
979
980 if Single_Lock then
981 Unlock_RTS;
982 end if;
983
984 Index := Self_Id.Chosen_Index;
985 Initialization.Undefer_Abort_Nestable (Self_Id);
986
987 if Self_Id.Pending_Action then
988 Initialization.Do_Pending_Action (Self_Id);
989 end if;
990
991 return;
992
993 else
994 -- Self_Id.Common.Call and Self_Id.Chosen_Index
995 -- should already be updated by the Caller.
996
997 if Self_Id.Chosen_Index /= No_Rendezvous
998 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
999 then
1000 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1001
1002 pragma Assert (Self_Id.Deferral_Level = 1);
1003
1004 -- We need an extra defer here, to keep abort
1005 -- deferred until we get into the accept body
1006
1007 Initialization.Defer_Abort_Nestable (Self_Id);
1008 end if;
1009 end if;
1010
1011 STPO.Unlock (Self_Id);
1012
1013 when No_Alternative_Open =>
1014 -- In this case, Index will be No_Rendezvous on return, which
1015 -- should cause a Program_Error if it is not a Delay_Mode.
1016
1017 -- If delay alternative exists (Delay_Mode) we should suspend
1018 -- until the delay expires.
1019
1020 Self_Id.Open_Accepts := null;
1021
1022 if Select_Mode = Delay_Mode then
1023 Self_Id.Common.State := Delay_Sleep;
1024
1025 loop
1026 Initialization.Poll_Base_Priority_Change (Self_Id);
1027 exit when
1028 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1029 Sleep (Self_Id, Delay_Sleep);
1030 end loop;
1031
1032 Self_Id.Common.State := Runnable;
1033 STPO.Unlock (Self_Id);
1034
1035 else
1036 STPO.Unlock (Self_Id);
1037
1038 if Single_Lock then
1039 Unlock_RTS;
1040 end if;
1041
1042 Initialization.Undefer_Abort (Self_Id);
1043 Ada.Exceptions.Raise_Exception
1044 (Program_Error'Identity, "Entry call not a delay mode");
1045 end if;
1046 end case;
1047
1048 if Single_Lock then
1049 Unlock_RTS;
1050 end if;
1051
1052 -- Caller has been chosen.
1053 -- Self_Id.Common.Call should already be updated by the Caller.
1054 -- Self_Id.Chosen_Index should either be updated by the Caller
1055 -- or by Test_Selective_Wait.
1056 -- On return, we sill start rendezvous unless the accept body is
1057 -- null. In the latter case, we will have already completed the RV.
1058
1059 Index := Self_Id.Chosen_Index;
1060 Initialization.Undefer_Abort_Nestable (Self_Id);
1061 end Selective_Wait;
1062
1063 ------------------------------------
1064 -- Setup_For_Rendezvous_With_Body --
1065 ------------------------------------
1066
1067 procedure Setup_For_Rendezvous_With_Body
1068 (Entry_Call : Entry_Call_Link;
1069 Acceptor : Task_Id) is
1070 begin
1071 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1072 Acceptor.Common.Call := Entry_Call;
1073
1074 if Entry_Call.State = Now_Abortable then
1075 Entry_Call.State := Was_Abortable;
1076 end if;
1077
1078 Boost_Priority (Entry_Call, Acceptor);
1079 end Setup_For_Rendezvous_With_Body;
1080
1081 ----------------
1082 -- Task_Count --
1083 ----------------
1084
1085 function Task_Count (E : Task_Entry_Index) return Natural is
1086 Self_Id : constant Task_Id := STPO.Self;
1087 Return_Count : Natural;
1088
1089 begin
1090 Initialization.Defer_Abort (Self_Id);
1091
1092 if Single_Lock then
1093 Lock_RTS;
1094 end if;
1095
1096 STPO.Write_Lock (Self_Id);
1097 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1098 STPO.Unlock (Self_Id);
1099
1100 if Single_Lock then
1101 Unlock_RTS;
1102 end if;
1103
1104 Initialization.Undefer_Abort (Self_Id);
1105 return Return_Count;
1106 end Task_Count;
1107
1108 ----------------------
1109 -- Task_Do_Or_Queue --
1110 ----------------------
1111
1112 function Task_Do_Or_Queue
1113 (Self_ID : Task_Id;
1114 Entry_Call : Entry_Call_Link;
1115 With_Abort : Boolean) return Boolean
1116 is
1117 E : constant Task_Entry_Index :=
1118 Task_Entry_Index (Entry_Call.E);
1119 Old_State : constant Entry_Call_State := Entry_Call.State;
1120 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1121 Parent : constant Task_Id := Acceptor.Common.Parent;
1122 Parent_Locked : Boolean := False;
1123 Null_Body : Boolean;
1124
1125 begin
1126 -- Find out whether Entry_Call can be accepted immediately.
1127 -- If the Acceptor is not callable, return False.
1128 -- If the rendezvous can start, initiate it.
1129 -- If the accept-body is trivial, also complete the rendezvous.
1130 -- If the acceptor is not ready, enqueue the call.
1131
1132 -- This should have a special case for Accept_Call and Accept_Trivial,
1133 -- so that we don't have the loop setup overhead, below.
1134
1135 -- The call state Done is used here and elsewhere to include both the
1136 -- case of normal successful completion, and the case of an exception
1137 -- being raised. The difference is that if an exception is raised no one
1138 -- will pay attention to the fact that State = Done. Instead the
1139 -- exception will be raised in Undefer_Abort, and control will skip past
1140 -- the place where we normally would resume from an entry call.
1141
1142 pragma Assert (not Queuing.Onqueue (Entry_Call));
1143
1144 -- We rely that the call is off-queue for protection, that the caller
1145 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1146 -- record for another call.
1147 -- We rely on the Caller's lock for call State mod's.
1148
1149 -- We can't lock Acceptor.Parent while holding Acceptor,
1150 -- so lock it in advance if we expect to need to lock it.
1151
1152 if Acceptor.Terminate_Alternative then
1153 STPO.Write_Lock (Parent);
1154 Parent_Locked := True;
1155 end if;
1156
1157 STPO.Write_Lock (Acceptor);
1158
1159 -- If the acceptor is not callable, abort the call and return False
1160
1161 if not Acceptor.Callable then
1162 STPO.Unlock (Acceptor);
1163
1164 if Parent_Locked then
1165 STPO.Unlock (Parent);
1166 end if;
1167
1168 pragma Assert (Entry_Call.State < Done);
1169
1170 -- In case we are not the caller, set up the caller
1171 -- to raise Tasking_Error when it wakes up.
1172
1173 STPO.Write_Lock (Entry_Call.Self);
1174 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1175 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1176 STPO.Unlock (Entry_Call.Self);
1177
1178 return False;
1179 end if;
1180
1181 -- Try to serve the call immediately
1182
1183 if Acceptor.Open_Accepts /= null then
1184 for J in Acceptor.Open_Accepts'Range loop
1185 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1186
1187 -- Commit acceptor to rendezvous with us
1188
1189 Acceptor.Chosen_Index := J;
1190 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1191 Acceptor.Open_Accepts := null;
1192
1193 -- Prevent abort while call is being served
1194
1195 if Entry_Call.State = Now_Abortable then
1196 Entry_Call.State := Was_Abortable;
1197 end if;
1198
1199 if Acceptor.Terminate_Alternative then
1200
1201 -- Cancel terminate alternative. See matching code in
1202 -- Selective_Wait and Vulnerable_Complete_Master.
1203
1204 Acceptor.Terminate_Alternative := False;
1205 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1206
1207 if Acceptor.Awake_Count = 1 then
1208
1209 -- Notify parent that acceptor is awake
1210
1211 pragma Assert (Parent.Awake_Count > 0);
1212
1213 Parent.Awake_Count := Parent.Awake_Count + 1;
1214
1215 if Parent.Common.State = Master_Completion_Sleep
1216 and then Acceptor.Master_of_Task = Parent.Master_Within
1217 then
1218 Parent.Common.Wait_Count :=
1219 Parent.Common.Wait_Count + 1;
1220 end if;
1221 end if;
1222 end if;
1223
1224 if Null_Body then
1225
1226 -- Rendezvous is over immediately
1227
1228 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1229 STPO.Unlock (Acceptor);
1230
1231 if Parent_Locked then
1232 STPO.Unlock (Parent);
1233 end if;
1234
1235 STPO.Write_Lock (Entry_Call.Self);
1236 Initialization.Wakeup_Entry_Caller
1237 (Self_ID, Entry_Call, Done);
1238 STPO.Unlock (Entry_Call.Self);
1239
1240 else
1241 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1242
1243 -- For terminate_alternative, acceptor may not be asleep
1244 -- yet, so we skip the wakeup
1245
1246 if Acceptor.Common.State /= Runnable then
1247 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1248 end if;
1249
1250 STPO.Unlock (Acceptor);
1251
1252 if Parent_Locked then
1253 STPO.Unlock (Parent);
1254 end if;
1255 end if;
1256
1257 return True;
1258 end if;
1259 end loop;
1260
1261 -- The acceptor is accepting, but not this entry
1262 end if;
1263
1264 -- If the acceptor was ready to accept this call,
1265 -- we would not have gotten this far, so now we should
1266 -- (re)enqueue the call, if the mode permits that.
1267
1268 if Entry_Call.Mode /= Conditional_Call
1269 or else not With_Abort
1270 then
1271 -- Timed_Call, Simple_Call, or Asynchronous_Call
1272
1273 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1274
1275 -- Update abortability of call
1276
1277 pragma Assert (Old_State < Done);
1278
1279 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1280
1281 STPO.Unlock (Acceptor);
1282
1283 if Parent_Locked then
1284 STPO.Unlock (Parent);
1285 end if;
1286
1287 if Old_State /= Entry_Call.State
1288 and then Entry_Call.State = Now_Abortable
1289 and then Entry_Call.Mode > Simple_Call
1290 and then Entry_Call.Self /= Self_ID
1291
1292 -- Asynchronous_Call or Conditional_Call
1293
1294 then
1295 -- Because of ATCB lock ordering rule
1296
1297 STPO.Write_Lock (Entry_Call.Self);
1298
1299 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1300
1301 -- Caller may not yet have reached wait-point
1302
1303 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1304 end if;
1305
1306 STPO.Unlock (Entry_Call.Self);
1307 end if;
1308
1309 else
1310 -- Conditional_Call and With_Abort
1311
1312 STPO.Unlock (Acceptor);
1313
1314 if Parent_Locked then
1315 STPO.Unlock (Parent);
1316 end if;
1317
1318 STPO.Write_Lock (Entry_Call.Self);
1319
1320 pragma Assert (Entry_Call.State >= Was_Abortable);
1321
1322 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1323 STPO.Unlock (Entry_Call.Self);
1324 end if;
1325
1326 return True;
1327 end Task_Do_Or_Queue;
1328
1329 ---------------------
1330 -- Task_Entry_Call --
1331 ---------------------
1332
1333 procedure Task_Entry_Call
1334 (Acceptor : Task_Id;
1335 E : Task_Entry_Index;
1336 Uninterpreted_Data : System.Address;
1337 Mode : Call_Modes;
1338 Rendezvous_Successful : out Boolean)
1339 is
1340 Self_Id : constant Task_Id := STPO.Self;
1341 Entry_Call : Entry_Call_Link;
1342
1343 begin
1344 -- If pragma Detect_Blocking is active then Program_Error must be
1345 -- raised if this potentially blocking operation is called from a
1346 -- protected action.
1347
1348 if System.Tasking.Detect_Blocking
1349 and then Self_Id.Common.Protected_Action_Nesting > 0
1350 then
1351 Ada.Exceptions.Raise_Exception
1352 (Program_Error'Identity, "potentially blocking operation");
1353 end if;
1354
1355 if Parameters.Runtime_Traces then
1356 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1357 end if;
1358
1359 if Mode = Simple_Call or else Mode = Conditional_Call then
1360 Call_Synchronous
1361 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1362
1363 else
1364 -- This is an asynchronous call
1365
1366 -- Abort must already be deferred by the compiler-generated code.
1367 -- Without this, an abort that occurs between the time that this
1368 -- call is made and the time that the abortable part's cleanup
1369 -- handler is set up might miss the cleanup handler and leave the
1370 -- call pending.
1371
1372 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1373 pragma Debug
1374 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1375 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1376 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1377 Entry_Call.Next := null;
1378 Entry_Call.Mode := Mode;
1379 Entry_Call.Cancellation_Attempted := False;
1380 Entry_Call.State := Not_Yet_Abortable;
1381 Entry_Call.E := Entry_Index (E);
1382 Entry_Call.Prio := Get_Priority (Self_Id);
1383 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1384 Entry_Call.Called_Task := Acceptor;
1385 Entry_Call.Called_PO := Null_Address;
1386 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1387
1388 if Single_Lock then
1389 Lock_RTS;
1390 end if;
1391
1392 if not Task_Do_Or_Queue
1393 (Self_Id, Entry_Call, With_Abort => True)
1394 then
1395 STPO.Write_Lock (Self_Id);
1396 Utilities.Exit_One_ATC_Level (Self_Id);
1397 STPO.Unlock (Self_Id);
1398
1399 if Single_Lock then
1400 Unlock_RTS;
1401 end if;
1402
1403 Initialization.Undefer_Abort (Self_Id);
1404
1405 if Parameters.Runtime_Traces then
1406 Send_Trace_Info (E_Missed, Acceptor);
1407 end if;
1408
1409 raise Tasking_Error;
1410 end if;
1411
1412 -- The following is special for async. entry calls.
1413 -- If the call was not queued abortably, we need to wait until
1414 -- it is before proceeding with the abortable part.
1415
1416 -- Wait_Until_Abortable can be called unconditionally here,
1417 -- but it is expensive.
1418
1419 if Entry_Call.State < Was_Abortable then
1420 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1421 end if;
1422
1423 if Single_Lock then
1424 Unlock_RTS;
1425 end if;
1426
1427 -- Note: following assignment needs to be atomic
1428
1429 Rendezvous_Successful := Entry_Call.State = Done;
1430 end if;
1431 end Task_Entry_Call;
1432
1433 -----------------------
1434 -- Task_Entry_Caller --
1435 -----------------------
1436
1437 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1438 Self_Id : constant Task_Id := STPO.Self;
1439 Entry_Call : Entry_Call_Link;
1440
1441 begin
1442 Entry_Call := Self_Id.Common.Call;
1443
1444 for Depth in 1 .. D loop
1445 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1446 pragma Assert (Entry_Call /= null);
1447 end loop;
1448
1449 return Entry_Call.Self;
1450 end Task_Entry_Caller;
1451
1452 --------------------------
1453 -- Timed_Selective_Wait --
1454 --------------------------
1455
1456 procedure Timed_Selective_Wait
1457 (Open_Accepts : Accept_List_Access;
1458 Select_Mode : Select_Modes;
1459 Uninterpreted_Data : out System.Address;
1460 Timeout : Duration;
1461 Mode : Delay_Modes;
1462 Index : out Select_Index)
1463 is
1464 Self_Id : constant Task_Id := STPO.Self;
1465 Treatment : Select_Treatment;
1466 Entry_Call : Entry_Call_Link;
1467 Caller : Task_Id;
1468 Selection : Select_Index;
1469 Open_Alternative : Boolean;
1470 Timedout : Boolean := False;
1471 Yielded : Boolean := True;
1472
1473 begin
1474 pragma Assert (Select_Mode = Delay_Mode);
1475
1476 Initialization.Defer_Abort (Self_Id);
1477
1478 -- If we are aborted here, the effect will be pending
1479
1480 if Single_Lock then
1481 Lock_RTS;
1482 end if;
1483
1484 STPO.Write_Lock (Self_Id);
1485
1486 if not Self_Id.Callable then
1487 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1488
1489 pragma Assert (Self_Id.Pending_Action);
1490
1491 STPO.Unlock (Self_Id);
1492
1493 if Single_Lock then
1494 Unlock_RTS;
1495 end if;
1496
1497 Initialization.Undefer_Abort (Self_Id);
1498
1499 -- Should never get here ???
1500
1501 pragma Assert (False);
1502 raise Standard'Abort_Signal;
1503 end if;
1504
1505 Uninterpreted_Data := Null_Address;
1506
1507 pragma Assert (Open_Accepts /= null);
1508
1509 Queuing.Select_Task_Entry_Call
1510 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1511
1512 -- Determine the kind and disposition of the select
1513
1514 Treatment := Default_Treatment (Select_Mode);
1515 Self_Id.Chosen_Index := No_Rendezvous;
1516
1517 if Open_Alternative then
1518 if Entry_Call /= null then
1519 if Open_Accepts (Selection).Null_Body then
1520 Treatment := Accept_Alternative_Completed;
1521
1522 else
1523 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1524 Treatment := Accept_Alternative_Selected;
1525 end if;
1526
1527 Self_Id.Chosen_Index := Selection;
1528
1529 elsif Treatment = No_Alternative_Open then
1530 Treatment := Accept_Alternative_Open;
1531 end if;
1532 end if;
1533
1534 -- Handle the select according to the disposition selected above
1535
1536 case Treatment is
1537 when Accept_Alternative_Selected =>
1538 -- Ready to rendezvous
1539 -- In this case the accept body is not Null_Body. Defer abort
1540 -- until it gets into the accept body.
1541
1542 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1543 Initialization.Defer_Abort (Self_Id);
1544 STPO.Unlock (Self_Id);
1545
1546 when Accept_Alternative_Completed =>
1547 -- Rendezvous is over
1548
1549 if Parameters.Runtime_Traces then
1550 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1551 end if;
1552
1553 STPO.Unlock (Self_Id);
1554 Caller := Entry_Call.Self;
1555
1556 STPO.Write_Lock (Caller);
1557 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1558 STPO.Unlock (Caller);
1559
1560 when Accept_Alternative_Open =>
1561
1562 -- Wait for caller
1563
1564 Self_Id.Open_Accepts := Open_Accepts;
1565
1566 -- Wait for a normal call and a pending action until the
1567 -- Wakeup_Time is reached.
1568
1569 -- Try to remove calls to Sleep in the loop below by letting the
1570 -- caller a chance of getting ready immediately, using Unlock
1571 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1572
1573 if Single_Lock then
1574 Unlock_RTS;
1575 else
1576 Unlock (Self_Id);
1577 end if;
1578
1579 if Self_Id.Open_Accepts /= null then
1580 Yield;
1581 end if;
1582
1583 if Single_Lock then
1584 Lock_RTS;
1585 else
1586 Write_Lock (Self_Id);
1587 end if;
1588
1589 -- Check if this task has been aborted while the lock was released
1590
1591 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1592 Self_Id.Open_Accepts := null;
1593 end if;
1594
1595 Self_Id.Common.State := Acceptor_Sleep;
1596
1597 loop
1598 Initialization.Poll_Base_Priority_Change (Self_Id);
1599 exit when Self_Id.Open_Accepts = null;
1600
1601 if Timedout then
1602 Sleep (Self_Id, Acceptor_Sleep);
1603 else
1604 if Parameters.Runtime_Traces then
1605 Send_Trace_Info (WT_Select,
1606 Self_Id,
1607 Integer (Open_Accepts'Length),
1608 Timeout);
1609 end if;
1610
1611 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1612 Acceptor_Sleep, Timedout, Yielded);
1613 end if;
1614
1615 if Timedout then
1616 Self_Id.Open_Accepts := null;
1617
1618 if Parameters.Runtime_Traces then
1619 Send_Trace_Info (E_Timeout);
1620 end if;
1621 end if;
1622 end loop;
1623
1624 Self_Id.Common.State := Runnable;
1625
1626 -- Self_Id.Common.Call should already be updated by the Caller if
1627 -- not aborted. It might also be ready to do rendezvous even if
1628 -- this wakes up due to an abort. Therefore, if the call is not
1629 -- empty we need to do the rendezvous if the accept body is not
1630 -- Null_Body.
1631
1632 if Self_Id.Chosen_Index /= No_Rendezvous
1633 and then Self_Id.Common.Call /= null
1634 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1635 then
1636 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1637
1638 pragma Assert (Self_Id.Deferral_Level = 1);
1639
1640 Initialization.Defer_Abort_Nestable (Self_Id);
1641
1642 -- Leave abort deferred until the accept body
1643 end if;
1644
1645 STPO.Unlock (Self_Id);
1646
1647 when No_Alternative_Open =>
1648 -- In this case, Index will be No_Rendezvous on return. We sleep
1649 -- for the time we need to.
1650 -- Wait for a signal or timeout. A wakeup can be made
1651 -- for several reasons:
1652 -- 1) Delay is expired
1653 -- 2) Pending_Action needs to be checked
1654 -- (Abort, Priority change)
1655 -- 3) Spurious wakeup
1656
1657 Self_Id.Open_Accepts := null;
1658 Self_Id.Common.State := Acceptor_Sleep;
1659
1660 Initialization.Poll_Base_Priority_Change (Self_Id);
1661
1662 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1663 Timedout, Yielded);
1664
1665 Self_Id.Common.State := Runnable;
1666
1667 STPO.Unlock (Self_Id);
1668
1669 when others =>
1670 -- Should never get here
1671 pragma Assert (False);
1672 null;
1673 end case;
1674
1675 if Single_Lock then
1676 Unlock_RTS;
1677 end if;
1678
1679 if not Yielded then
1680 Yield;
1681 end if;
1682
1683 -- Caller has been chosen
1684
1685 -- Self_Id.Common.Call should already be updated by the Caller
1686
1687 -- Self_Id.Chosen_Index should either be updated by the Caller
1688 -- or by Test_Selective_Wait
1689
1690 Index := Self_Id.Chosen_Index;
1691 Initialization.Undefer_Abort_Nestable (Self_Id);
1692
1693 -- Start rendezvous, if not already completed
1694 end Timed_Selective_Wait;
1695
1696 ---------------------------
1697 -- Timed_Task_Entry_Call --
1698 ---------------------------
1699
1700 procedure Timed_Task_Entry_Call
1701 (Acceptor : Task_Id;
1702 E : Task_Entry_Index;
1703 Uninterpreted_Data : System.Address;
1704 Timeout : Duration;
1705 Mode : Delay_Modes;
1706 Rendezvous_Successful : out Boolean)
1707 is
1708 Self_Id : constant Task_Id := STPO.Self;
1709 Level : ATC_Level;
1710 Entry_Call : Entry_Call_Link;
1711 Yielded : Boolean;
1712
1713 begin
1714 -- If pragma Detect_Blocking is active then Program_Error must be
1715 -- raised if this potentially blocking operation is called from a
1716 -- protected action.
1717
1718 if System.Tasking.Detect_Blocking
1719 and then Self_Id.Common.Protected_Action_Nesting > 0
1720 then
1721 Ada.Exceptions.Raise_Exception
1722 (Program_Error'Identity, "potentially blocking operation");
1723 end if;
1724
1725 Initialization.Defer_Abort (Self_Id);
1726 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1727
1728 pragma Debug
1729 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1730 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1731
1732 if Parameters.Runtime_Traces then
1733 Send_Trace_Info (WT_Call, Acceptor,
1734 Entry_Index (E), Timeout);
1735 end if;
1736
1737 Level := Self_Id.ATC_Nesting_Level;
1738 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1739 Entry_Call.Next := null;
1740 Entry_Call.Mode := Timed_Call;
1741 Entry_Call.Cancellation_Attempted := False;
1742
1743 -- If this is a call made inside of an abort deferred region,
1744 -- the call should be never abortable.
1745
1746 if Self_Id.Deferral_Level > 1 then
1747 Entry_Call.State := Never_Abortable;
1748 else
1749 Entry_Call.State := Now_Abortable;
1750 end if;
1751
1752 Entry_Call.E := Entry_Index (E);
1753 Entry_Call.Prio := Get_Priority (Self_Id);
1754 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1755 Entry_Call.Called_Task := Acceptor;
1756 Entry_Call.Called_PO := Null_Address;
1757 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1758
1759 -- Note: the caller will undefer abort on return (see WARNING above)
1760
1761 if Single_Lock then
1762 Lock_RTS;
1763 end if;
1764
1765 if not Task_Do_Or_Queue
1766 (Self_Id, Entry_Call, With_Abort => True)
1767 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 -- Try to remove calls to Sleep in the loop below by letting the caller
1807 -- a chance of getting ready immediately, using Unlock & Yield.
1808 -- See similar action in Wait_For_Completion & Selective_Wait.
1809
1810 if Single_Lock then
1811 Unlock_RTS;
1812 else
1813 Unlock (Self_Id);
1814 end if;
1815
1816 if Self_Id.Open_Accepts /= null then
1817 Yield;
1818 end if;
1819
1820 if Single_Lock then
1821 Lock_RTS;
1822 else
1823 Write_Lock (Self_Id);
1824 end if;
1825
1826 -- Check if this task has been aborted while the lock was released
1827
1828 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1829 Self_Id.Open_Accepts := null;
1830 end if;
1831
1832 Self_Id.Common.State := Acceptor_Sleep;
1833
1834 loop
1835 Initialization.Poll_Base_Priority_Change (Self_Id);
1836
1837 exit when Self_Id.Open_Accepts = null;
1838
1839 Sleep (Self_Id, Acceptor_Sleep);
1840 end loop;
1841
1842 Self_Id.Common.State := Runnable;
1843 end Wait_For_Call;
1844
1845 end System.Tasking.Rendezvous;
Mirror of the offical gcc git repository hosted at gcc.gnu.org