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