?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / ada / s-tpobop.adb
blob2e865821bc96f42a00a23842b58fefbbf0eb0807
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 . P R O T E C T E D _ O B J E C T S . --
6 -- O P E R A T I O N S --
7 -- --
8 -- B o d y --
9 -- --
10 -- $Revision: 1.13 $
11 -- --
12 -- Copyright (C) 1991-2001, Florida State University --
13 -- --
14 -- GNARL is free software; you can redistribute it and/or modify it under --
15 -- terms of the GNU General Public License as published by the Free Soft- --
16 -- ware Foundation; either version 2, or (at your option) any later ver- --
17 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
18 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
19 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
20 -- for more details. You should have received a copy of the GNU General --
21 -- Public License distributed with GNARL; see file COPYING. If not, write --
22 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
23 -- MA 02111-1307, USA. --
24 -- --
25 -- As a special exception, if other files instantiate generics from this --
26 -- unit, or you link this unit with other files to produce an executable, --
27 -- this unit does not by itself cause the resulting executable to be --
28 -- covered by the GNU General Public License. This exception does not --
29 -- however invalidate any other reasons why the executable file might be --
30 -- covered by the GNU Public License. --
31 -- --
32 -- GNARL was developed by the GNARL team at Florida State University. It is --
33 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
34 -- State University (http://www.gnat.com). --
35 -- --
36 ------------------------------------------------------------------------------
37
38 -- This package contains all the extended primitives related to
39 -- Protected_Objects with entries.
40
41 -- The handling of protected objects with no entries is done in
42 -- System.Tasking.Protected_Objects, the simple routines for protected
43 -- objects with entries in System.Tasking.Protected_Objects.Entries.
44
45 -- The split between Entries and Operations is needed to break circular
46 -- dependencies inside the run time.
47
48 -- This package contains all primitives related to Protected_Objects.
49 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
50
51 with Ada.Exceptions;
52 -- Used for Exception_ID
53 -- Null_Id
54 -- Raise_Exception
55
56 with System.Task_Primitives.Operations;
57 -- used for Initialize_Lock
58 -- Write_Lock
59 -- Unlock
60 -- Get_Priority
61 -- Wakeup
62
63 with System.Tasking.Entry_Calls;
64 -- used for Wait_For_Completion
65 -- Wait_Until_Abortable
66
67 with System.Tasking.Initialization;
68 -- Used for Defer_Abort,
69 -- Undefer_Abort,
70 -- Change_Base_Priority
71
72 pragma Elaborate_All (System.Tasking.Initialization);
73 -- This insures that tasking is initialized if any protected objects are
74 -- created.
75
76 with System.Tasking.Queuing;
77 -- used for Enqueue
78 -- Broadcast_Program_Error
79 -- Select_Protected_Entry_Call
80 -- Onqueue
81 -- Count_Waiting
82
83 with System.Tasking.Rendezvous;
84 -- used for Task_Do_Or_Queue
85
86 with System.Tasking.Debug;
87 -- used for Trace
88
89 package body System.Tasking.Protected_Objects.Operations is
90
91 package STPO renames System.Task_Primitives.Operations;
92
93 use Task_Primitives;
94 use Tasking;
95 use Ada.Exceptions;
96 use Entries;
97
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
101
102 procedure Update_For_Queue_To_PO
103 (Entry_Call : Entry_Call_Link;
104 With_Abort : Boolean);
105 pragma Inline (Update_For_Queue_To_PO);
106 -- Update the state of an existing entry call to reflect
107 -- the fact that it is being enqueued, based on
108 -- whether the current queuing action is with or without abort.
109 -- Call this only while holding the PO's lock.
110 -- It returns with the PO's lock still held.
111
112 ---------------------------------
113 -- Cancel_Protected_Entry_Call --
114 ---------------------------------
115
116 -- Compiler interface only. Do not call from within the RTS.
117 -- This should have analogous effect to Cancel_Task_Entry_Call,
118 -- setting the value of Block.Cancelled instead of returning
119 -- the parameter value Cancelled.
120
121 -- The effect should be idempotent, since the call may already
122 -- have been dequeued.
123
124 -- source code:
125
126 -- select r.e;
127 -- ...A...
128 -- then abort
129 -- ...B...
130 -- end select;
131
132 -- expanded code:
133
134 -- declare
135 -- X : protected_entry_index := 1;
136 -- B80b : communication_block;
137 -- _init_proc (B80b);
138 -- begin
139 -- begin
140 -- A79b : label
141 -- A79b : declare
142 -- procedure _clean is
143 -- begin
144 -- if enqueued (B80b) then
145 -- cancel_protected_entry_call (B80b);
146 -- end if;
147 -- return;
148 -- end _clean;
149 -- begin
150 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
151 -- null_address, asynchronous_call, B80b, objectF => 0);
152 -- if enqueued (B80b) then
153 -- ...B...
154 -- end if;
155 -- at end
156 -- _clean;
157 -- end A79b;
158 -- exception
159 -- when _abort_signal =>
160 -- abort_undefer.all;
161 -- null;
162 -- end;
163 -- if not cancelled (B80b) then
164 -- x := ...A...
165 -- end if;
166 -- end;
167
168 -- If the entry call completes after we get into the abortable part,
169 -- Abort_Signal should be raised and ATC will take us to the at-end
170 -- handler, which will call _clean.
171
172 -- If the entry call returns with the call already completed,
173 -- we can skip this, and use the "if enqueued()" to go past
174 -- the at-end handler, but we will still call _clean.
175
176 -- If the abortable part completes before the entry call is Done,
177 -- it will call _clean.
178
179 -- If the entry call or the abortable part raises an exception,
180 -- we will still call _clean, but the value of Cancelled should not matter.
181
182 -- Whoever calls _clean first gets to decide whether the call
183 -- has been "cancelled".
184
185 -- Enqueued should be true if there is any chance that the call
186 -- is still on a queue. It seems to be safe to make it True if
187 -- the call was Onqueue at some point before return from
188 -- Protected_Entry_Call.
189
190 -- Cancelled should be true iff the abortable part completed
191 -- and succeeded in cancelling the entry call before it completed.
192
193 -- ?????
194 -- The need for Enqueued is less obvious.
195 -- The "if enqueued()" tests are not necessary, since both
196 -- Cancel_Protected_Entry_Call and Protected_Entry_Call must
197 -- do the same test internally, with locking. The one that
198 -- makes cancellation conditional may be a useful heuristic
199 -- since at least 1/2 the time the call should be off-queue
200 -- by that point. The other one seems totally useless, since
201 -- Protected_Entry_Call must do the same check and then
202 -- possibly wait for the call to be abortable, internally.
203
204 -- We can check Call.State here without locking the caller's mutex,
205 -- since the call must be over after returning from Wait_For_Completion.
206 -- No other task can access the call record at this point.
207
208 procedure Cancel_Protected_Entry_Call
209 (Block : in out Communication_Block)
210 is
211 begin
212 Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
213 end Cancel_Protected_Entry_Call;
214
215 ---------------
216 -- Cancelled --
217 ---------------
218
219 function Cancelled (Block : Communication_Block) return Boolean is
220 begin
221 return Block.Cancelled;
222 end Cancelled;
223
224 -------------------------
225 -- Complete_Entry_Body --
226 -------------------------
227
228 procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
229 begin
230 Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
231 end Complete_Entry_Body;
232
233 --------------
234 -- Enqueued --
235 --------------
236
237 function Enqueued (Block : Communication_Block) return Boolean is
238 begin
239 return Block.Enqueued;
240 end Enqueued;
241
242 -------------------------------------
243 -- Exceptional_Complete_Entry_Body --
244 -------------------------------------
245
246 procedure Exceptional_Complete_Entry_Body
247 (Object : Protection_Entries_Access;
248 Ex : Ada.Exceptions.Exception_Id)
249 is
250 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
251
252 begin
253 pragma Debug
254 (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
255
256 -- We must have abort deferred, since we are inside
257 -- a protected operation.
258
259 if Entry_Call /= null then
260
261 -- The call was not requeued.
262
263 Entry_Call.Exception_To_Raise := Ex;
264
265 -- ?????
266 -- The caller should do the following, after return from this
267 -- procedure, if Call_In_Progress /= null
268 -- Write_Lock (Entry_Call.Self);
269 -- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done);
270 -- Unlock (Entry_Call.Self);
271
272 end if;
273 end Exceptional_Complete_Entry_Body;
274
275 --------------------
276 -- PO_Do_Or_Queue --
277 --------------------
278
279 procedure PO_Do_Or_Queue
280 (Self_ID : Task_ID;
281 Object : Protection_Entries_Access;
282 Entry_Call : Entry_Call_Link;
283 With_Abort : Boolean)
284 is
285 E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E);
286 New_Object : Protection_Entries_Access;
287 Ceiling_Violation : Boolean;
288 Barrier_Value : Boolean;
289
290 begin
291 -- When the Action procedure for an entry body returns, it is either
292 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
293 -- is queued, having executed a requeue statement.
294
295 Barrier_Value :=
296 Object.Entry_Bodies (
297 Object.Find_Body_Index (Object.Compiler_Info, E)).
298 Barrier (Object.Compiler_Info, E);
299
300 if Barrier_Value then
301
302 -- Not abortable while service is in progress.
303
304 if Entry_Call.State = Now_Abortable then
305 Entry_Call.State := Was_Abortable;
306 end if;
307
308 Object.Call_In_Progress := Entry_Call;
309
310 pragma Debug
311 (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
312 Object.Entry_Bodies (
313 Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
314 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
315
316 if Object.Call_In_Progress /= null then
317
318 -- Body of current entry served call to completion
319
320 Object.Call_In_Progress := null;
321 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
322
323 else
324 -- Body of current entry requeued the call
325 New_Object := To_Protection (Entry_Call.Called_PO);
326
327 if New_Object = null then
328
329 -- Call was requeued to a task
330
331 if not Rendezvous.Task_Do_Or_Queue
332 (Self_ID, Entry_Call,
333 With_Abort => Entry_Call.Requeue_With_Abort)
334 then
335 Queuing.Broadcast_Program_Error
336 (Self_ID, Object, Entry_Call);
337 end if;
338 return;
339 end if;
340
341 if Object /= New_Object then
342 -- Requeue is on a different object
343
344 Lock_Entries (New_Object, Ceiling_Violation);
345
346 if Ceiling_Violation then
347 Object.Call_In_Progress := null;
348 Queuing.Broadcast_Program_Error
349 (Self_ID, Object, Entry_Call);
350
351 else
352 PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
353 PO_Service_Entries (Self_ID, New_Object);
354 Unlock_Entries (New_Object);
355 end if;
356
357 else
358 -- Requeue is on same protected object
359
360 if Entry_Call.Requeue_With_Abort
361 and then Entry_Call.Cancellation_Attempted
362 then
363 -- If this is a requeue with abort and someone tried
364 -- to cancel this call, cancel it at this point.
365
366 Entry_Call.State := Cancelled;
367 return;
368 end if;
369
370 if not With_Abort or else
371 Entry_Call.Mode /= Conditional_Call
372 then
373 E := Protected_Entry_Index (Entry_Call.E);
374 Queuing.Enqueue
375 (New_Object.Entry_Queues (E), Entry_Call);
376 Update_For_Queue_To_PO (Entry_Call, With_Abort);
377
378 else
379 -- ?????
380 -- Can we convert this recursion to a loop?
381
382 PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort);
383 end if;
384 end if;
385 end if;
386
387 elsif Entry_Call.Mode /= Conditional_Call or else
388 not With_Abort then
389 Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
390 Update_For_Queue_To_PO (Entry_Call, With_Abort);
391
392 else
393 -- Conditional_Call and With_Abort
394
395 STPO.Write_Lock (Entry_Call.Self);
396 pragma Assert (Entry_Call.State >= Was_Abortable);
397 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
398 STPO.Unlock (Entry_Call.Self);
399 end if;
400
401 exception
402 when others =>
403 Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
404 end PO_Do_Or_Queue;
405
406 ------------------------
407 -- PO_Service_Entries --
408 ------------------------
409
410 procedure PO_Service_Entries
411 (Self_ID : Task_ID;
412 Object : Protection_Entries_Access)
413 is
414 Entry_Call : Entry_Call_Link;
415 E : Protected_Entry_Index;
416 Caller : Task_ID;
417 New_Object : Protection_Entries_Access;
418 Ceiling_Violation : Boolean;
419
420 begin
421 loop
422 Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
423
424 if Entry_Call /= null then
425 E := Protected_Entry_Index (Entry_Call.E);
426
427 -- Not abortable while service is in progress.
428
429 if Entry_Call.State = Now_Abortable then
430 Entry_Call.State := Was_Abortable;
431 end if;
432
433 Object.Call_In_Progress := Entry_Call;
434
435 begin
436 pragma Debug
437 (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
438 Object.Entry_Bodies (
439 Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
440 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
441 exception
442 when others =>
443 Queuing.Broadcast_Program_Error
444 (Self_ID, Object, Entry_Call);
445 end;
446
447 if Object.Call_In_Progress /= null then
448 Object.Call_In_Progress := null;
449 Caller := Entry_Call.Self;
450 STPO.Write_Lock (Caller);
451 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
452 STPO.Unlock (Caller);
453
454 else
455 -- Call needs to be requeued
456
457 New_Object := To_Protection (Entry_Call.Called_PO);
458
459 if New_Object = null then
460
461 -- Call is to be requeued to a task entry
462
463 if not Rendezvous.Task_Do_Or_Queue
464 (Self_ID, Entry_Call,
465 With_Abort => Entry_Call.Requeue_With_Abort)
466 then
467 Queuing.Broadcast_Program_Error
468 (Self_ID, Object, Entry_Call);
469 end if;
470
471 else
472 -- Call should be requeued to a PO
473
474 if Object /= New_Object then
475 -- Requeue is to different PO
476
477 Lock_Entries (New_Object, Ceiling_Violation);
478
479 if Ceiling_Violation then
480 Object.Call_In_Progress := null;
481 Queuing.Broadcast_Program_Error
482 (Self_ID, Object, Entry_Call);
483
484 else
485 PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call,
486 Entry_Call.Requeue_With_Abort);
487 PO_Service_Entries (Self_ID, New_Object);
488 Unlock_Entries (New_Object);
489 end if;
490
491 else
492 -- Requeue is to same protected object
493
494 -- ??? Try to compensate apparent failure of the
495 -- scheduler on some OS (e.g VxWorks) to give higher
496 -- priority tasks a chance to run (see CXD6002).
497
498 STPO.Yield (False);
499
500 if Entry_Call.Requeue_With_Abort
501 and then Entry_Call.Cancellation_Attempted
502 then
503 -- If this is a requeue with abort and someone tried
504 -- to cancel this call, cancel it at this point.
505
506 Entry_Call.State := Cancelled;
507 exit;
508 end if;
509
510 if not Entry_Call.Requeue_With_Abort or else
511 Entry_Call.Mode /= Conditional_Call
512 then
513 E := Protected_Entry_Index (Entry_Call.E);
514 Queuing.Enqueue
515 (New_Object.Entry_Queues (E), Entry_Call);
516 Update_For_Queue_To_PO (Entry_Call,
517 Entry_Call.Requeue_With_Abort);
518
519 else
520 PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call,
521 Entry_Call.Requeue_With_Abort);
522 end if;
523 end if;
524 end if;
525 end if;
526
527 else
528 exit;
529 end if;
530 end loop;
531 end PO_Service_Entries;
532
533 ---------------------
534 -- Protected_Count --
535 ---------------------
536
537 function Protected_Count
538 (Object : Protection_Entries'Class;
539 E : Protected_Entry_Index)
540 return Natural
541 is
542 begin
543 return Queuing.Count_Waiting (Object.Entry_Queues (E));
544 end Protected_Count;
545
546 --------------------------
547 -- Protected_Entry_Call --
548 --------------------------
549
550 -- Compiler interface only. Do not call from within the RTS.
551
552 -- select r.e;
553 -- ...A...
554 -- else
555 -- ...B...
556 -- end select;
557
558 -- declare
559 -- X : protected_entry_index := 1;
560 -- B85b : communication_block;
561 -- _init_proc (B85b);
562 -- begin
563 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
564 -- null_address, conditional_call, B85b, objectF => 0);
565 -- if cancelled (B85b) then
566 -- ...B...
567 -- else
568 -- ...A...
569 -- end if;
570 -- end;
571
572 -- See also Cancel_Protected_Entry_Call for code expansion of
573 -- asynchronous entry call.
574
575 -- The initial part of this procedure does not need to lock the
576 -- the calling task's ATCB, up to the point where the call record
577 -- first may be queued (PO_Do_Or_Queue), since before that no
578 -- other task will have access to the record.
579
580 -- If this is a call made inside of an abort deferred region,
581 -- the call should be never abortable.
582
583 -- If the call was not queued abortably, we need to wait
584 -- until it is before proceeding with the abortable part.
585
586 -- There are some heuristics here, just to save time for
587 -- frequently occurring cases. For example, we check
588 -- Initially_Abortable to try to avoid calling the procedure
589 -- Wait_Until_Abortable, since the normal case for async.
590 -- entry calls is to be queued abortably.
591
592 -- Another heuristic uses the Block.Enqueued to try to avoid
593 -- calling Cancel_Protected_Entry_Call if the call can be
594 -- served immediately.
595
596 procedure Protected_Entry_Call
597 (Object : Protection_Entries_Access;
598 E : Protected_Entry_Index;
599 Uninterpreted_Data : System.Address;
600 Mode : Call_Modes;
601 Block : out Communication_Block)
602 is
603 Self_ID : Task_ID := STPO.Self;
604 Entry_Call : Entry_Call_Link;
605 Initially_Abortable : Boolean;
606 Ceiling_Violation : Boolean;
607
608 begin
609 pragma Debug
610 (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
611
612 if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
613 Raise_Exception (Storage_Error'Identity,
614 "not enough ATC nesting levels");
615 end if;
616
617 Initialization.Defer_Abort (Self_ID);
618 Lock_Entries (Object, Ceiling_Violation);
619
620 if Ceiling_Violation then
621
622 -- Failed ceiling check
623
624 Initialization.Undefer_Abort (Self_ID);
625 raise Program_Error;
626 end if;
627
628 Block.Self := Self_ID;
629 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
630 pragma Debug
631 (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
632 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
633 Entry_Call :=
634 Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
635 Entry_Call.Next := null;
636 Entry_Call.Mode := Mode;
637 Entry_Call.Cancellation_Attempted := False;
638
639 if Self_ID.Deferral_Level > 1 then
640 Entry_Call.State := Never_Abortable;
641 else
642 Entry_Call.State := Now_Abortable;
643 end if;
644
645 Entry_Call.E := Entry_Index (E);
646 Entry_Call.Prio := STPO.Get_Priority (Self_ID);
647 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
648 Entry_Call.Called_PO := To_Address (Object);
649 Entry_Call.Called_Task := null;
650 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
651
652 PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
653 Initially_Abortable := Entry_Call.State = Now_Abortable;
654 PO_Service_Entries (Self_ID, Object);
655
656 Unlock_Entries (Object);
657
658 -- Try to prevent waiting later (in Cancel_Protected_Entry_Call)
659 -- for completed or cancelled calls. (This is a heuristic, only.)
660
661 if Entry_Call.State >= Done then
662
663 -- Once State >= Done it will not change any more.
664
665 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
666 pragma Debug
667 (Debug.Trace (Self_ID, "PEC: exited to ATC level: " &
668 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
669 Block.Enqueued := False;
670 Block.Cancelled := Entry_Call.State = Cancelled;
671 Initialization.Undefer_Abort (Self_ID);
672 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
673 return;
674
675 else
676 -- In this case we cannot conclude anything,
677 -- since State can change concurrently.
678 null;
679 end if;
680
681 -- Now for the general case.
682
683 if Mode = Asynchronous_Call then
684
685 -- Try to avoid an expensive call.
686
687 if not Initially_Abortable then
688 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
689 end if;
690
691 elsif Mode < Asynchronous_Call then
692
693 -- Simple_Call or Conditional_Call
694
695 STPO.Write_Lock (Self_ID);
696 Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call);
697 STPO.Unlock (Self_ID);
698 Block.Cancelled := Entry_Call.State = Cancelled;
699
700 else
701 pragma Assert (False);
702 null;
703 end if;
704
705 Initialization.Undefer_Abort (Self_ID);
706 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
707
708 end Protected_Entry_Call;
709
710 ----------------------------
711 -- Protected_Entry_Caller --
712 ----------------------------
713
714 function Protected_Entry_Caller (Object : Protection_Entries'Class)
715 return Task_ID is
716 begin
717 return Object.Call_In_Progress.Self;
718 end Protected_Entry_Caller;
719
720 -----------------------------
721 -- Requeue_Protected_Entry --
722 -----------------------------
723
724 -- Compiler interface only. Do not call from within the RTS.
725
726 -- entry e when b is
727 -- begin
728 -- b := false;
729 -- ...A...
730 -- requeue e2;
731 -- end e;
732
733 -- procedure rPT__E10b (O : address; P : address; E :
734 -- protected_entry_index) is
735 -- type rTVP is access rTV;
736 -- freeze rTVP []
737 -- _object : rTVP := rTVP!(O);
738 -- begin
739 -- declare
740 -- rR : protection renames _object._object;
741 -- vP : integer renames _object.v;
742 -- bP : boolean renames _object.b;
743 -- begin
744 -- b := false;
745 -- ...A...
746 -- requeue_protected_entry (rR'unchecked_access, rR'
747 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
748 -- 0);
749 -- return;
750 -- end;
751 -- complete_entry_body (_object._object'unchecked_access, objectF =>
752 -- 0);
753 -- return;
754 -- exception
755 -- when others =>
756 -- abort_undefer.all;
757 -- exceptional_complete_entry_body (_object._object'
758 -- unchecked_access, current_exception, objectF => 0);
759 -- return;
760 -- end rPT__E10b;
761
762 procedure Requeue_Protected_Entry
763 (Object : Protection_Entries_Access;
764 New_Object : Protection_Entries_Access;
765 E : Protected_Entry_Index;
766 With_Abort : Boolean)
767 is
768 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
769
770 begin
771 pragma Debug
772 (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
773 pragma Assert (STPO.Self.Deferral_Level > 0);
774
775 Entry_Call.E := Entry_Index (E);
776 Entry_Call.Called_PO := To_Address (New_Object);
777 Entry_Call.Called_Task := null;
778 Entry_Call.Requeue_With_Abort := With_Abort;
779 Object.Call_In_Progress := null;
780 end Requeue_Protected_Entry;
781
782 -------------------------------------
783 -- Requeue_Task_To_Protected_Entry --
784 -------------------------------------
785
786 -- Compiler interface only.
787
788 -- accept e1 do
789 -- ...A...
790 -- requeue r.e2;
791 -- end e1;
792
793 -- A79b : address;
794 -- L78b : label
795 -- begin
796 -- accept_call (1, A79b);
797 -- ...A...
798 -- requeue_task_to_protected_entry (rTV!(r)._object'
799 -- unchecked_access, 2, false, new_objectF => 0);
800 -- goto L78b;
801 -- <<L78b>>
802 -- complete_rendezvous;
803 -- exception
804 -- when all others =>
805 -- exceptional_complete_rendezvous (get_gnat_exception);
806 -- end;
807
808 procedure Requeue_Task_To_Protected_Entry
809 (New_Object : Protection_Entries_Access;
810 E : Protected_Entry_Index;
811 With_Abort : Boolean)
812 is
813 Self_ID : constant Task_ID := STPO.Self;
814 Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
815
816 begin
817 Initialization.Defer_Abort (Self_ID);
818 STPO.Write_Lock (Self_ID);
819 Entry_Call.Needs_Requeue := True;
820 Entry_Call.Requeue_With_Abort := With_Abort;
821 Entry_Call.Called_PO := To_Address (New_Object);
822 Entry_Call.Called_Task := null;
823 STPO.Unlock (Self_ID);
824 Entry_Call.E := Entry_Index (E);
825 Initialization.Undefer_Abort (Self_ID);
826 end Requeue_Task_To_Protected_Entry;
827
828 -- ??????
829 -- Do we really need to lock Self_ID above?
830 -- Might the caller be trying to cancel?
831 -- If so, it should fail, since the call state should not be
832 -- abortable while the call is in service.
833
834 ---------------------
835 -- Service_Entries --
836 ---------------------
837
838 procedure Service_Entries (Object : Protection_Entries_Access) is
839 Self_ID : constant Task_ID := STPO.Self;
840 begin
841 PO_Service_Entries (Self_ID, Object);
842 end Service_Entries;
843
844 --------------------------------
845 -- Timed_Protected_Entry_Call --
846 --------------------------------
847
848 -- Compiler interface only. Do not call from within the RTS.
849
850 procedure Timed_Protected_Entry_Call
851 (Object : Protection_Entries_Access;
852 E : Protected_Entry_Index;
853 Uninterpreted_Data : System.Address;
854 Timeout : Duration;
855 Mode : Delay_Modes;
856 Entry_Call_Successful : out Boolean)
857 is
858 Self_ID : Task_ID := STPO.Self;
859 Entry_Call : Entry_Call_Link;
860 Ceiling_Violation : Boolean;
861
862 begin
863 if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
864 Raise_Exception (Storage_Error'Identity,
865 "not enough ATC nesting levels");
866 end if;
867
868 Initialization.Defer_Abort (Self_ID);
869 Lock_Entries (Object, Ceiling_Violation);
870
871 if Ceiling_Violation then
872 Initialization.Undefer_Abort (Self_ID);
873 raise Program_Error;
874 end if;
875
876 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
877 pragma Debug
878 (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " &
879 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
880 Entry_Call :=
881 Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
882 Entry_Call.Next := null;
883 Entry_Call.Mode := Timed_Call;
884 Entry_Call.Cancellation_Attempted := False;
885
886 if Self_ID.Deferral_Level > 1 then
887 Entry_Call.State := Never_Abortable;
888 else
889 Entry_Call.State := Now_Abortable;
890 end if;
891
892 Entry_Call.E := Entry_Index (E);
893 Entry_Call.Prio := STPO.Get_Priority (Self_ID);
894 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
895 Entry_Call.Called_PO := To_Address (Object);
896 Entry_Call.Called_Task := null;
897 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
898
899 PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
900 PO_Service_Entries (Self_ID, Object);
901
902 Unlock_Entries (Object);
903
904 -- Try to avoid waiting for completed or cancelled calls.
905
906 if Entry_Call.State >= Done then
907 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
908 pragma Debug
909 (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " &
910 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
911 Entry_Call_Successful := Entry_Call.State = Done;
912 Initialization.Undefer_Abort (Self_ID);
913 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
914 return;
915 end if;
916
917 Entry_Calls.Wait_For_Completion_With_Timeout
918 (Self_ID, Entry_Call, Timeout, Mode);
919 Initialization.Undefer_Abort (Self_ID);
920 Entry_Call_Successful := Entry_Call.State = Done;
921 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
922 end Timed_Protected_Entry_Call;
923
924 ----------------------------
925 -- Update_For_Queue_To_PO --
926 ----------------------------
927
928 -- Update the state of an existing entry call, based on
929 -- whether the current queuing action is with or without abort.
930 -- Call this only while holding the server's lock.
931 -- It returns with the server's lock released.
932
933 New_State : constant array (Boolean, Entry_Call_State)
934 of Entry_Call_State :=
935 (True =>
936 (Never_Abortable => Never_Abortable,
937 Not_Yet_Abortable => Now_Abortable,
938 Was_Abortable => Now_Abortable,
939 Now_Abortable => Now_Abortable,
940 Done => Done,
941 Cancelled => Cancelled),
942 False =>
943 (Never_Abortable => Never_Abortable,
944 Not_Yet_Abortable => Not_Yet_Abortable,
945 Was_Abortable => Was_Abortable,
946 Now_Abortable => Now_Abortable,
947 Done => Done,
948 Cancelled => Cancelled)
949 );
950
951 procedure Update_For_Queue_To_PO
952 (Entry_Call : Entry_Call_Link;
953 With_Abort : Boolean)
954 is
955 Old : Entry_Call_State := Entry_Call.State;
956
957 begin
958 pragma Assert (Old < Done);
959
960 Entry_Call.State := New_State (With_Abort, Entry_Call.State);
961
962 if Entry_Call.Mode = Asynchronous_Call then
963 if Old < Was_Abortable and then
964 Entry_Call.State = Now_Abortable
965 then
966 STPO.Write_Lock (Entry_Call.Self);
967
968 if Entry_Call.Self.Common.State = Async_Select_Sleep then
969 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
970 end if;
971
972 STPO.Unlock (Entry_Call.Self);
973 end if;
974
975 elsif Entry_Call.Mode = Conditional_Call then
976 pragma Assert (Entry_Call.State < Was_Abortable);
977 null;
978 end if;
979 end Update_For_Queue_To_PO;
980
981 end System.Tasking.Protected_Objects.Operations;
Mirror of the offical gcc git repository hosted at gcc.gnu.org