?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* expr.c (gfc_copy_shape_excluding): Change && to ||.
[official-gcc.git] / gcc / ada / s-tasren.adb
blob9002eeeb03134da64c29fa56bdcf0a702d166e2f
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-2004, 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 -- Accept body is null, so rendezvous is over immediately.
886
887 if Parameters.Runtime_Traces then
888 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
889 end if;
890
891 STPO.Unlock (Self_Id);
892 Caller := Entry_Call.Self;
893
894 STPO.Write_Lock (Caller);
895 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
896 STPO.Unlock (Caller);
897
898 when Accept_Alternative_Open =>
899 -- Wait for caller.
900
901 Self_Id.Open_Accepts := Open_Accepts;
902 pragma Debug
903 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
904
905 if Parameters.Runtime_Traces then
906 Send_Trace_Info (W_Select, Self_Id,
907 Integer (Open_Accepts'Length));
908 end if;
909
910 Wait_For_Call (Self_Id);
911
912 pragma Assert (Self_Id.Open_Accepts = null);
913
914 -- Self_Id.Common.Call should already be updated by the Caller if
915 -- not aborted. It might also be ready to do rendezvous even if
916 -- this wakes up due to an abortion.
917 -- Therefore, if the call is not empty we need to do the
918 -- rendezvous if the accept body is not Null_Body.
919
920 -- Aren't the first two conditions below redundant???
921
922 if Self_Id.Chosen_Index /= No_Rendezvous
923 and then Self_Id.Common.Call /= null
924 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
925 then
926 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
927
928 pragma Assert (Self_Id.Deferral_Level = 1);
929
930 Initialization.Defer_Abort_Nestable (Self_Id);
931
932 -- Leave abort deferred until the accept body
933 end if;
934
935 STPO.Unlock (Self_Id);
936
937 when Else_Selected =>
938 pragma Assert (Self_Id.Open_Accepts = null);
939
940 if Parameters.Runtime_Traces then
941 Send_Trace_Info (M_Select_Else);
942 end if;
943
944 STPO.Unlock (Self_Id);
945
946 when Terminate_Selected =>
947 -- Terminate alternative is open
948
949 Self_Id.Open_Accepts := Open_Accepts;
950 Self_Id.Common.State := Acceptor_Sleep;
951
952 -- Notify ancestors that this task is on a terminate alternative.
953
954 STPO.Unlock (Self_Id);
955 Utilities.Make_Passive (Self_Id, Task_Completed => False);
956 STPO.Write_Lock (Self_Id);
957
958 -- Wait for normal entry call or termination
959
960 Wait_For_Call (Self_Id);
961
962 pragma Assert (Self_Id.Open_Accepts = null);
963
964 if Self_Id.Terminate_Alternative then
965 -- An entry call should have reset this to False,
966 -- so we must be aborted.
967 -- We cannot be in an async. select, since that
968 -- is not legal, so the abort must be of the entire
969 -- task. Therefore, we do not need to cancel the
970 -- terminate alternative. The cleanup will be done
971 -- in Complete_Master.
972
973 pragma Assert (Self_Id.Pending_ATC_Level = 0);
974 pragma Assert (Self_Id.Awake_Count = 0);
975
976 STPO.Unlock (Self_Id);
977
978 if Single_Lock then
979 Unlock_RTS;
980 end if;
981
982 Index := Self_Id.Chosen_Index;
983 Initialization.Undefer_Abort_Nestable (Self_Id);
984
985 if Self_Id.Pending_Action then
986 Initialization.Do_Pending_Action (Self_Id);
987 end if;
988
989 return;
990
991 else
992 -- Self_Id.Common.Call and Self_Id.Chosen_Index
993 -- should already be updated by the Caller.
994
995 if Self_Id.Chosen_Index /= No_Rendezvous
996 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
997 then
998 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
999
1000 pragma Assert (Self_Id.Deferral_Level = 1);
1001
1002 -- We need an extra defer here, to keep abort
1003 -- deferred until we get into the accept body
1004
1005 Initialization.Defer_Abort_Nestable (Self_Id);
1006 end if;
1007 end if;
1008
1009 STPO.Unlock (Self_Id);
1010
1011 when No_Alternative_Open =>
1012 -- In this case, Index will be No_Rendezvous on return, which
1013 -- should cause a Program_Error if it is not a Delay_Mode.
1014
1015 -- If delay alternative exists (Delay_Mode) we should suspend
1016 -- until the delay expires.
1017
1018 Self_Id.Open_Accepts := null;
1019
1020 if Select_Mode = Delay_Mode then
1021 Self_Id.Common.State := Delay_Sleep;
1022
1023 loop
1024 Initialization.Poll_Base_Priority_Change (Self_Id);
1025 exit when
1026 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1027 Sleep (Self_Id, Delay_Sleep);
1028 end loop;
1029
1030 Self_Id.Common.State := Runnable;
1031 STPO.Unlock (Self_Id);
1032
1033 else
1034 STPO.Unlock (Self_Id);
1035
1036 if Single_Lock then
1037 Unlock_RTS;
1038 end if;
1039
1040 Initialization.Undefer_Abort (Self_Id);
1041 Ada.Exceptions.Raise_Exception
1042 (Program_Error'Identity, "Entry call not a delay mode");
1043 end if;
1044 end case;
1045
1046 if Single_Lock then
1047 Unlock_RTS;
1048 end if;
1049
1050 -- Caller has been chosen.
1051 -- Self_Id.Common.Call should already be updated by the Caller.
1052 -- Self_Id.Chosen_Index should either be updated by the Caller
1053 -- or by Test_Selective_Wait.
1054 -- On return, we sill start rendezvous unless the accept body is
1055 -- null. In the latter case, we will have already completed the RV.
1056
1057 Index := Self_Id.Chosen_Index;
1058 Initialization.Undefer_Abort_Nestable (Self_Id);
1059 end Selective_Wait;
1060
1061 ------------------------------------
1062 -- Setup_For_Rendezvous_With_Body --
1063 ------------------------------------
1064
1065 procedure Setup_For_Rendezvous_With_Body
1066 (Entry_Call : Entry_Call_Link;
1067 Acceptor : Task_Id) is
1068 begin
1069 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1070 Acceptor.Common.Call := Entry_Call;
1071
1072 if Entry_Call.State = Now_Abortable then
1073 Entry_Call.State := Was_Abortable;
1074 end if;
1075
1076 Boost_Priority (Entry_Call, Acceptor);
1077 end Setup_For_Rendezvous_With_Body;
1078
1079 ----------------
1080 -- Task_Count --
1081 ----------------
1082
1083 function Task_Count (E : Task_Entry_Index) return Natural is
1084 Self_Id : constant Task_Id := STPO.Self;
1085 Return_Count : Natural;
1086
1087 begin
1088 Initialization.Defer_Abort (Self_Id);
1089
1090 if Single_Lock then
1091 Lock_RTS;
1092 end if;
1093
1094 STPO.Write_Lock (Self_Id);
1095 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1096 STPO.Unlock (Self_Id);
1097
1098 if Single_Lock then
1099 Unlock_RTS;
1100 end if;
1101
1102 Initialization.Undefer_Abort (Self_Id);
1103 return Return_Count;
1104 end Task_Count;
1105
1106 ----------------------
1107 -- Task_Do_Or_Queue --
1108 ----------------------
1109
1110 function Task_Do_Or_Queue
1111 (Self_ID : Task_Id;
1112 Entry_Call : Entry_Call_Link;
1113 With_Abort : Boolean) return Boolean
1114 is
1115 E : constant Task_Entry_Index :=
1116 Task_Entry_Index (Entry_Call.E);
1117 Old_State : constant Entry_Call_State := Entry_Call.State;
1118 Acceptor : constant Task_Id := Entry_Call.Called_Task;
1119 Parent : constant Task_Id := Acceptor.Common.Parent;
1120 Parent_Locked : Boolean := False;
1121 Null_Body : Boolean;
1122
1123 begin
1124 -- Find out whether Entry_Call can be accepted immediately.
1125 -- If the Acceptor is not callable, return False.
1126 -- If the rendezvous can start, initiate it.
1127 -- If the accept-body is trivial, also complete the rendezvous.
1128 -- If the acceptor is not ready, enqueue the call.
1129
1130 -- This should have a special case for Accept_Call and Accept_Trivial,
1131 -- so that we don't have the loop setup overhead, below.
1132
1133 -- The call state Done is used here and elsewhere to include both the
1134 -- case of normal successful completion, and the case of an exception
1135 -- being raised. The difference is that if an exception is raised no one
1136 -- will pay attention to the fact that State = Done. Instead the
1137 -- exception will be raised in Undefer_Abort, and control will skip past
1138 -- the place where we normally would resume from an entry call.
1139
1140 pragma Assert (not Queuing.Onqueue (Entry_Call));
1141
1142 -- We rely that the call is off-queue for protection, that the caller
1143 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call
1144 -- record for another call.
1145 -- We rely on the Caller's lock for call State mod's.
1146
1147 -- We can't lock Acceptor.Parent while holding Acceptor,
1148 -- so lock it in advance if we expect to need to lock it.
1149
1150 if Acceptor.Terminate_Alternative then
1151 STPO.Write_Lock (Parent);
1152 Parent_Locked := True;
1153 end if;
1154
1155 STPO.Write_Lock (Acceptor);
1156
1157 -- If the acceptor is not callable, abort the call and return False.
1158
1159 if not Acceptor.Callable then
1160 STPO.Unlock (Acceptor);
1161
1162 if Parent_Locked then
1163 STPO.Unlock (Parent);
1164 end if;
1165
1166 pragma Assert (Entry_Call.State < Done);
1167
1168 -- In case we are not the caller, set up the caller
1169 -- to raise Tasking_Error when it wakes up.
1170
1171 STPO.Write_Lock (Entry_Call.Self);
1172 Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1173 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1174 STPO.Unlock (Entry_Call.Self);
1175
1176 return False;
1177 end if;
1178
1179 -- Try to serve the call immediately.
1180
1181 if Acceptor.Open_Accepts /= null then
1182 for J in Acceptor.Open_Accepts'Range loop
1183 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1184
1185 -- Commit acceptor to rendezvous with us.
1186
1187 Acceptor.Chosen_Index := J;
1188 Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1189 Acceptor.Open_Accepts := null;
1190
1191 -- Prevent abort while call is being served.
1192
1193 if Entry_Call.State = Now_Abortable then
1194 Entry_Call.State := Was_Abortable;
1195 end if;
1196
1197 if Acceptor.Terminate_Alternative then
1198 -- Cancel terminate alternative.
1199 -- See matching code in Selective_Wait and
1200 -- Vulnerable_Complete_Master.
1201
1202 Acceptor.Terminate_Alternative := False;
1203 Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1204
1205 if Acceptor.Awake_Count = 1 then
1206
1207 -- Notify parent that acceptor is awake.
1208
1209 pragma Assert (Parent.Awake_Count > 0);
1210
1211 Parent.Awake_Count := Parent.Awake_Count + 1;
1212
1213 if Parent.Common.State = Master_Completion_Sleep
1214 and then Acceptor.Master_of_Task = Parent.Master_Within
1215 then
1216 Parent.Common.Wait_Count :=
1217 Parent.Common.Wait_Count + 1;
1218 end if;
1219 end if;
1220 end if;
1221
1222 if Null_Body then
1223 -- Rendezvous is over immediately.
1224
1225 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1226 STPO.Unlock (Acceptor);
1227
1228 if Parent_Locked then
1229 STPO.Unlock (Parent);
1230 end if;
1231
1232 STPO.Write_Lock (Entry_Call.Self);
1233 Initialization.Wakeup_Entry_Caller
1234 (Self_ID, Entry_Call, Done);
1235 STPO.Unlock (Entry_Call.Self);
1236
1237 else
1238 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1239
1240 -- For terminate_alternative, acceptor may not be
1241 -- asleep yet, so we skip the wakeup
1242
1243 if Acceptor.Common.State /= Runnable then
1244 STPO.Wakeup (Acceptor, Acceptor_Sleep);
1245 end if;
1246
1247 STPO.Unlock (Acceptor);
1248
1249 if Parent_Locked then
1250 STPO.Unlock (Parent);
1251 end if;
1252 end if;
1253
1254 return True;
1255 end if;
1256 end loop;
1257
1258 -- The acceptor is accepting, but not this entry.
1259 end if;
1260
1261 -- If the acceptor was ready to accept this call,
1262 -- we would not have gotten this far, so now we should
1263 -- (re)enqueue the call, if the mode permits that.
1264
1265 if Entry_Call.Mode /= Conditional_Call
1266 or else not With_Abort
1267 then
1268 -- Timed_Call, Simple_Call, or Asynchronous_Call
1269
1270 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1271
1272 -- Update abortability of call
1273
1274 pragma Assert (Old_State < Done);
1275
1276 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1277
1278 STPO.Unlock (Acceptor);
1279
1280 if Parent_Locked then
1281 STPO.Unlock (Parent);
1282 end if;
1283
1284 if Old_State /= Entry_Call.State
1285 and then Entry_Call.State = Now_Abortable
1286 and then Entry_Call.Mode > Simple_Call
1287 and then Entry_Call.Self /= Self_ID
1288
1289 -- Asynchronous_Call or Conditional_Call
1290
1291 then
1292 -- Because of ATCB lock ordering rule
1293
1294 STPO.Write_Lock (Entry_Call.Self);
1295
1296 if Entry_Call.Self.Common.State = Async_Select_Sleep then
1297
1298 -- Caller may not yet have reached wait-point
1299
1300 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1301 end if;
1302
1303 STPO.Unlock (Entry_Call.Self);
1304 end if;
1305
1306 else
1307 -- Conditional_Call and With_Abort
1308
1309 STPO.Unlock (Acceptor);
1310
1311 if Parent_Locked then
1312 STPO.Unlock (Parent);
1313 end if;
1314
1315 STPO.Write_Lock (Entry_Call.Self);
1316
1317 pragma Assert (Entry_Call.State >= Was_Abortable);
1318
1319 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1320 STPO.Unlock (Entry_Call.Self);
1321 end if;
1322
1323 return True;
1324 end Task_Do_Or_Queue;
1325
1326 ---------------------
1327 -- Task_Entry_Call --
1328 ---------------------
1329
1330 procedure Task_Entry_Call
1331 (Acceptor : Task_Id;
1332 E : Task_Entry_Index;
1333 Uninterpreted_Data : System.Address;
1334 Mode : Call_Modes;
1335 Rendezvous_Successful : out Boolean)
1336 is
1337 Self_Id : constant Task_Id := STPO.Self;
1338 Entry_Call : Entry_Call_Link;
1339
1340 begin
1341 -- If pragma Detect_Blocking is active then Program_Error must be
1342 -- raised if this potentially blocking operation is called from a
1343 -- protected action.
1344
1345 if System.Tasking.Detect_Blocking
1346 and then Self_Id.Common.Protected_Action_Nesting > 0
1347 then
1348 Ada.Exceptions.Raise_Exception
1349 (Program_Error'Identity, "potentially blocking operation");
1350 end if;
1351
1352 if Parameters.Runtime_Traces then
1353 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1354 end if;
1355
1356 if Mode = Simple_Call or else Mode = Conditional_Call then
1357 Call_Synchronous
1358 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1359
1360 else
1361 -- This is an asynchronous call
1362
1363 -- Abortion must already be deferred by the compiler-generated
1364 -- code. Without this, an abortion that occurs between the time
1365 -- that this call is made and the time that the abortable part's
1366 -- cleanup handler is set up might miss the cleanup handler and
1367 -- leave the call pending.
1368
1369 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1370 pragma Debug
1371 (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1372 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1373 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1374 Entry_Call.Next := null;
1375 Entry_Call.Mode := Mode;
1376 Entry_Call.Cancellation_Attempted := False;
1377 Entry_Call.State := Not_Yet_Abortable;
1378 Entry_Call.E := Entry_Index (E);
1379 Entry_Call.Prio := Get_Priority (Self_Id);
1380 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1381 Entry_Call.Called_Task := Acceptor;
1382 Entry_Call.Called_PO := Null_Address;
1383 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1384
1385 if Single_Lock then
1386 Lock_RTS;
1387 end if;
1388
1389 if not Task_Do_Or_Queue
1390 (Self_Id, Entry_Call, With_Abort => True)
1391 then
1392 STPO.Write_Lock (Self_Id);
1393 Utilities.Exit_One_ATC_Level (Self_Id);
1394 STPO.Unlock (Self_Id);
1395
1396 if Single_Lock then
1397 Unlock_RTS;
1398 end if;
1399
1400 Initialization.Undefer_Abort (Self_Id);
1401
1402 if Parameters.Runtime_Traces then
1403 Send_Trace_Info (E_Missed, Acceptor);
1404 end if;
1405
1406 raise Tasking_Error;
1407 end if;
1408
1409 -- The following is special for async. entry calls.
1410 -- If the call was not queued abortably, we need to wait until
1411 -- it is before proceeding with the abortable part.
1412
1413 -- Wait_Until_Abortable can be called unconditionally here,
1414 -- but it is expensive.
1415
1416 if Entry_Call.State < Was_Abortable then
1417 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1418 end if;
1419
1420 if Single_Lock then
1421 Unlock_RTS;
1422 end if;
1423
1424 -- Note: following assignment needs to be atomic.
1425
1426 Rendezvous_Successful := Entry_Call.State = Done;
1427 end if;
1428 end Task_Entry_Call;
1429
1430 -----------------------
1431 -- Task_Entry_Caller --
1432 -----------------------
1433
1434 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1435 Self_Id : constant Task_Id := STPO.Self;
1436 Entry_Call : Entry_Call_Link;
1437
1438 begin
1439 Entry_Call := Self_Id.Common.Call;
1440
1441 for Depth in 1 .. D loop
1442 Entry_Call := Entry_Call.Acceptor_Prev_Call;
1443 pragma Assert (Entry_Call /= null);
1444 end loop;
1445
1446 return Entry_Call.Self;
1447 end Task_Entry_Caller;
1448
1449 --------------------------
1450 -- Timed_Selective_Wait --
1451 --------------------------
1452
1453 procedure Timed_Selective_Wait
1454 (Open_Accepts : Accept_List_Access;
1455 Select_Mode : Select_Modes;
1456 Uninterpreted_Data : out System.Address;
1457 Timeout : Duration;
1458 Mode : Delay_Modes;
1459 Index : out Select_Index)
1460 is
1461 Self_Id : constant Task_Id := STPO.Self;
1462 Treatment : Select_Treatment;
1463 Entry_Call : Entry_Call_Link;
1464 Caller : Task_Id;
1465 Selection : Select_Index;
1466 Open_Alternative : Boolean;
1467 Timedout : Boolean := False;
1468 Yielded : Boolean := True;
1469
1470 begin
1471 pragma Assert (Select_Mode = Delay_Mode);
1472
1473 Initialization.Defer_Abort (Self_Id);
1474
1475 -- If we are aborted here, the effect will be pending
1476
1477 if Single_Lock then
1478 Lock_RTS;
1479 end if;
1480
1481 STPO.Write_Lock (Self_Id);
1482
1483 if not Self_Id.Callable then
1484 pragma Assert (Self_Id.Pending_ATC_Level = 0);
1485
1486 pragma Assert (Self_Id.Pending_Action);
1487
1488 STPO.Unlock (Self_Id);
1489
1490 if Single_Lock then
1491 Unlock_RTS;
1492 end if;
1493
1494 Initialization.Undefer_Abort (Self_Id);
1495
1496 -- Should never get here ???
1497
1498 pragma Assert (False);
1499 raise Standard'Abort_Signal;
1500 end if;
1501
1502 Uninterpreted_Data := Null_Address;
1503
1504 pragma Assert (Open_Accepts /= null);
1505
1506 Queuing.Select_Task_Entry_Call
1507 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1508
1509 -- Determine the kind and disposition of the select.
1510
1511 Treatment := Default_Treatment (Select_Mode);
1512 Self_Id.Chosen_Index := No_Rendezvous;
1513
1514 if Open_Alternative then
1515 if Entry_Call /= null then
1516 if Open_Accepts (Selection).Null_Body then
1517 Treatment := Accept_Alternative_Completed;
1518
1519 else
1520 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1521 Treatment := Accept_Alternative_Selected;
1522 end if;
1523
1524 Self_Id.Chosen_Index := Selection;
1525
1526 elsif Treatment = No_Alternative_Open then
1527 Treatment := Accept_Alternative_Open;
1528 end if;
1529 end if;
1530
1531 -- Handle the select according to the disposition selected above.
1532
1533 case Treatment is
1534 when Accept_Alternative_Selected =>
1535 -- Ready to rendezvous
1536 -- In this case the accept body is not Null_Body. Defer abort
1537 -- until it gets into the accept body.
1538
1539 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1540 Initialization.Defer_Abort (Self_Id);
1541 STPO.Unlock (Self_Id);
1542
1543 when Accept_Alternative_Completed =>
1544 -- Rendezvous is over
1545
1546 if Parameters.Runtime_Traces then
1547 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1548 end if;
1549
1550 STPO.Unlock (Self_Id);
1551 Caller := Entry_Call.Self;
1552
1553 STPO.Write_Lock (Caller);
1554 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1555 STPO.Unlock (Caller);
1556
1557 when Accept_Alternative_Open =>
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.
1568 -- See similar action in Wait_For_Completion & Wait_For_Call.
1569
1570 if Single_Lock then
1571 Unlock_RTS;
1572 else
1573 Unlock (Self_Id);
1574 end if;
1575
1576 if Self_Id.Open_Accepts /= null then
1577 Yield;
1578 end if;
1579
1580 if Single_Lock then
1581 Lock_RTS;
1582 else
1583 Write_Lock (Self_Id);
1584 end if;
1585
1586 -- Check if this task has been aborted while the lock was released
1587
1588 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1589 Self_Id.Open_Accepts := null;
1590 end if;
1591
1592 Self_Id.Common.State := Acceptor_Sleep;
1593
1594 loop
1595 Initialization.Poll_Base_Priority_Change (Self_Id);
1596 exit when Self_Id.Open_Accepts = null;
1597
1598 if Timedout then
1599 Sleep (Self_Id, Acceptor_Sleep);
1600 else
1601 if Parameters.Runtime_Traces then
1602 Send_Trace_Info (WT_Select,
1603 Self_Id,
1604 Integer (Open_Accepts'Length),
1605 Timeout);
1606 end if;
1607
1608 STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1609 Acceptor_Sleep, Timedout, Yielded);
1610 end if;
1611
1612 if Timedout then
1613 Self_Id.Open_Accepts := null;
1614
1615 if Parameters.Runtime_Traces then
1616 Send_Trace_Info (E_Timeout);
1617 end if;
1618 end if;
1619 end loop;
1620
1621 Self_Id.Common.State := Runnable;
1622
1623 -- Self_Id.Common.Call should already be updated by the Caller if
1624 -- not aborted. It might also be ready to do rendezvous even if
1625 -- this wakes up due to an abortion.
1626 -- Therefore, if the call is not empty we need to do the
1627 -- rendezvous if the accept body is not Null_Body.
1628
1629 if Self_Id.Chosen_Index /= No_Rendezvous
1630 and then Self_Id.Common.Call /= null
1631 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1632 then
1633 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1634
1635 pragma Assert (Self_Id.Deferral_Level = 1);
1636
1637 Initialization.Defer_Abort_Nestable (Self_Id);
1638
1639 -- Leave abort deferred until the accept body
1640 end if;
1641
1642 STPO.Unlock (Self_Id);
1643
1644 when No_Alternative_Open =>
1645 -- In this case, Index will be No_Rendezvous on return. We sleep
1646 -- for the time we need to.
1647 -- Wait for a signal or timeout. A wakeup can be made
1648 -- for several reasons:
1649 -- 1) Delay is expired
1650 -- 2) Pending_Action needs to be checked
1651 -- (Abortion, Priority change)
1652 -- 3) Spurious wakeup
1653
1654 Self_Id.Open_Accepts := null;
1655 Self_Id.Common.State := Acceptor_Sleep;
1656
1657 Initialization.Poll_Base_Priority_Change (Self_Id);
1658
1659 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1660 Timedout, Yielded);
1661
1662 Self_Id.Common.State := Runnable;
1663
1664 STPO.Unlock (Self_Id);
1665
1666 when others =>
1667 -- Should never get here
1668 pragma Assert (False);
1669 null;
1670 end case;
1671
1672 if Single_Lock then
1673 Unlock_RTS;
1674 end if;
1675
1676 if not Yielded then
1677 Yield;
1678 end if;
1679
1680 -- Caller has been chosen
1681
1682 -- Self_Id.Common.Call should already be updated by the Caller
1683
1684 -- Self_Id.Chosen_Index should either be updated by the Caller
1685 -- or by Test_Selective_Wait
1686
1687 Index := Self_Id.Chosen_Index;
1688 Initialization.Undefer_Abort_Nestable (Self_Id);
1689
1690 -- Start rendezvous, if not already completed
1691 end Timed_Selective_Wait;
1692
1693 ---------------------------
1694 -- Timed_Task_Entry_Call --
1695 ---------------------------
1696
1697 procedure Timed_Task_Entry_Call
1698 (Acceptor : Task_Id;
1699 E : Task_Entry_Index;
1700 Uninterpreted_Data : System.Address;
1701 Timeout : Duration;
1702 Mode : Delay_Modes;
1703 Rendezvous_Successful : out Boolean)
1704 is
1705 Self_Id : constant Task_Id := STPO.Self;
1706 Level : ATC_Level;
1707 Entry_Call : Entry_Call_Link;
1708 Yielded : Boolean;
1709
1710 begin
1711 -- If pragma Detect_Blocking is active then Program_Error must be
1712 -- raised if this potentially blocking operation is called from a
1713 -- protected action.
1714
1715 if System.Tasking.Detect_Blocking
1716 and then Self_Id.Common.Protected_Action_Nesting > 0
1717 then
1718 Ada.Exceptions.Raise_Exception
1719 (Program_Error'Identity, "potentially blocking operation");
1720 end if;
1721
1722 Initialization.Defer_Abort (Self_Id);
1723 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1724
1725 pragma Debug
1726 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1727 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1728
1729 if Parameters.Runtime_Traces then
1730 Send_Trace_Info (WT_Call, Acceptor,
1731 Entry_Index (E), Timeout);
1732 end if;
1733
1734 Level := Self_Id.ATC_Nesting_Level;
1735 Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1736 Entry_Call.Next := null;
1737 Entry_Call.Mode := Timed_Call;
1738 Entry_Call.Cancellation_Attempted := False;
1739
1740 -- If this is a call made inside of an abort deferred region,
1741 -- the call should be never abortable.
1742
1743 if Self_Id.Deferral_Level > 1 then
1744 Entry_Call.State := Never_Abortable;
1745 else
1746 Entry_Call.State := Now_Abortable;
1747 end if;
1748
1749 Entry_Call.E := Entry_Index (E);
1750 Entry_Call.Prio := Get_Priority (Self_Id);
1751 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1752 Entry_Call.Called_Task := Acceptor;
1753 Entry_Call.Called_PO := Null_Address;
1754 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1755
1756 -- Note: the caller will undefer abortion on return (see WARNING above)
1757
1758 if Single_Lock then
1759 Lock_RTS;
1760 end if;
1761
1762 if not Task_Do_Or_Queue
1763 (Self_Id, Entry_Call, With_Abort => True)
1764 then
1765 STPO.Write_Lock (Self_Id);
1766 Utilities.Exit_One_ATC_Level (Self_Id);
1767 STPO.Unlock (Self_Id);
1768
1769 if Single_Lock then
1770 Unlock_RTS;
1771 end if;
1772
1773 Initialization.Undefer_Abort (Self_Id);
1774
1775 if Parameters.Runtime_Traces then
1776 Send_Trace_Info (E_Missed, Acceptor);
1777 end if;
1778 raise Tasking_Error;
1779 end if;
1780
1781 Write_Lock (Self_Id);
1782 Entry_Calls.Wait_For_Completion_With_Timeout
1783 (Entry_Call, Timeout, Mode, Yielded);
1784 Unlock (Self_Id);
1785
1786 if Single_Lock then
1787 Unlock_RTS;
1788 end if;
1789
1790 -- ??? Do we need to yield in case Yielded is False
1791
1792 Rendezvous_Successful := Entry_Call.State = Done;
1793 Initialization.Undefer_Abort (Self_Id);
1794 Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1795 end Timed_Task_Entry_Call;
1796
1797 -------------------
1798 -- Wait_For_Call --
1799 -------------------
1800
1801 procedure Wait_For_Call (Self_Id : Task_Id) is
1802 begin
1803 -- Try to remove calls to Sleep in the loop below by letting the caller
1804 -- a chance of getting ready immediately, using Unlock & Yield.
1805 -- See similar action in Wait_For_Completion & Selective_Wait.
1806
1807 if Single_Lock then
1808 Unlock_RTS;
1809 else
1810 Unlock (Self_Id);
1811 end if;
1812
1813 if Self_Id.Open_Accepts /= null then
1814 Yield;
1815 end if;
1816
1817 if Single_Lock then
1818 Lock_RTS;
1819 else
1820 Write_Lock (Self_Id);
1821 end if;
1822
1823 -- Check if this task has been aborted while the lock was released.
1824
1825 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1826 Self_Id.Open_Accepts := null;
1827 end if;
1828
1829 Self_Id.Common.State := Acceptor_Sleep;
1830
1831 loop
1832 Initialization.Poll_Base_Priority_Change (Self_Id);
1833
1834 exit when Self_Id.Open_Accepts = null;
1835
1836 Sleep (Self_Id, Acceptor_Sleep);
1837 end loop;
1838
1839 Self_Id.Common.State := Runnable;
1840 end Wait_For_Call;
1841
1842 end System.Tasking.Rendezvous;
Mirror of the offical gcc git repository hosted at gcc.gnu.org