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