OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [s-tasren.adb] - Blame information for rev 281

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.