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