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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tpobop.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4
--                                                                          --
5
--               SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS                --
6
--                                                                          --
7
--                                  B o d y                                 --
8
--                                                                          --
9
--         Copyright (C) 1998-2011, 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
--  This package contains all extended primitives related to Protected_Objects
33
--  with entries.
34
 
35
--  The handling of protected objects with no entries is done in
36
--  System.Tasking.Protected_Objects, the simple routines for protected
37
--  objects with entries in System.Tasking.Protected_Objects.Entries.
38
 
39
--  The split between Entries and Operations is needed to break circular
40
--  dependencies inside the run time.
41
 
42
--  This package contains all primitives related to Protected_Objects.
43
--  Note: the compiler generates direct calls to this interface, via Rtsfind.
44
 
45
with System.Task_Primitives.Operations;
46
with System.Tasking.Entry_Calls;
47
with System.Tasking.Queuing;
48
with System.Tasking.Rendezvous;
49
with System.Tasking.Utilities;
50
with System.Tasking.Debug;
51
with System.Parameters;
52
with System.Traces.Tasking;
53
with System.Restrictions;
54
 
55
with System.Tasking.Initialization;
56
pragma Elaborate_All (System.Tasking.Initialization);
57
--  Insures that tasking is initialized if any protected objects are created
58
 
59
package body System.Tasking.Protected_Objects.Operations is
60
 
61
   package STPO renames System.Task_Primitives.Operations;
62
 
63
   use Parameters;
64
   use Task_Primitives;
65
   use Ada.Exceptions;
66
   use Entries;
67
 
68
   use System.Restrictions;
69
   use System.Restrictions.Rident;
70
   use System.Traces;
71
   use System.Traces.Tasking;
72
 
73
   -----------------------
74
   -- Local Subprograms --
75
   -----------------------
76
 
77
   procedure Update_For_Queue_To_PO
78
     (Entry_Call : Entry_Call_Link;
79
      With_Abort : Boolean);
80
   pragma Inline (Update_For_Queue_To_PO);
81
   --  Update the state of an existing entry call to reflect the fact that it
82
   --  is being enqueued, based on whether the current queuing action is with
83
   --  or without abort. Call this only while holding the PO's lock. It returns
84
   --  with the PO's lock still held.
85
 
86
   procedure Requeue_Call
87
     (Self_Id    : Task_Id;
88
      Object     : Protection_Entries_Access;
89
      Entry_Call : Entry_Call_Link);
90
   --  Handle requeue of Entry_Call.
91
   --  In particular, queue the call if needed, or service it immediately
92
   --  if possible.
93
 
94
   ---------------------------------
95
   -- Cancel_Protected_Entry_Call --
96
   ---------------------------------
97
 
98
   --  Compiler interface only (do not call from within the RTS)
99
 
100
   --  This should have analogous effect to Cancel_Task_Entry_Call, setting
101
   --  the value of Block.Cancelled instead of returning the parameter value
102
   --  Cancelled.
103
 
104
   --  The effect should be idempotent, since the call may already have been
105
   --  dequeued.
106
 
107
   --  Source code:
108
 
109
   --      select r.e;
110
   --         ...A...
111
   --      then abort
112
   --         ...B...
113
   --      end select;
114
 
115
   --  Expanded code:
116
 
117
   --      declare
118
   --         X : protected_entry_index := 1;
119
   --         B80b : communication_block;
120
   --         communication_blockIP (B80b);
121
 
122
   --      begin
123
   --         begin
124
   --            A79b : label
125
   --            A79b : declare
126
   --               procedure _clean is
127
   --               begin
128
   --                  if enqueued (B80b) then
129
   --                     cancel_protected_entry_call (B80b);
130
   --                  end if;
131
   --                  return;
132
   --               end _clean;
133
 
134
   --            begin
135
   --               protected_entry_call (rTV!(r)._object'unchecked_access, X,
136
   --                 null_address, asynchronous_call, B80b, objectF => 0);
137
   --               if enqueued (B80b) then
138
   --                  ...B...
139
   --               end if;
140
   --            at end
141
   --               _clean;
142
   --            end A79b;
143
 
144
   --         exception
145
   --            when _abort_signal =>
146
   --               abort_undefer.all;
147
   --               null;
148
   --         end;
149
 
150
   --         if not cancelled (B80b) then
151
   --            x := ...A...
152
   --         end if;
153
   --      end;
154
 
155
   --  If the entry call completes after we get into the abortable part,
156
   --  Abort_Signal should be raised and ATC will take us to the at-end
157
   --  handler, which will call _clean.
158
 
159
   --  If the entry call returns with the call already completed, we can skip
160
   --  this, and use the "if enqueued()" to go past the at-end handler, but we
161
   --  will still call _clean.
162
 
163
   --  If the abortable part completes before the entry call is Done, it will
164
   --  call _clean.
165
 
166
   --  If the entry call or the abortable part raises an exception,
167
   --  we will still call _clean, but the value of Cancelled should not matter.
168
 
169
   --  Whoever calls _clean first gets to decide whether the call
170
   --  has been "cancelled".
171
 
172
   --  Enqueued should be true if there is any chance that the call is still on
173
   --  a queue. It seems to be safe to make it True if the call was Onqueue at
174
   --  some point before return from Protected_Entry_Call.
175
 
176
   --  Cancelled should be true iff the abortable part completed
177
   --  and succeeded in cancelling the entry call before it completed.
178
 
179
   --  ?????
180
   --  The need for Enqueued is less obvious. The "if enqueued ()" tests are
181
   --  not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
182
   --  must do the same test internally, with locking. The one that makes
183
   --  cancellation conditional may be a useful heuristic since at least 1/2
184
   --  the time the call should be off-queue by that point. The other one seems
185
   --  totally useless, since Protected_Entry_Call must do the same check and
186
   --  then possibly wait for the call to be abortable, internally.
187
 
188
   --  We can check Call.State here without locking the caller's mutex,
189
   --  since the call must be over after returning from Wait_For_Completion.
190
   --  No other task can access the call record at this point.
191
 
192
   procedure Cancel_Protected_Entry_Call
193
     (Block : in out Communication_Block) is
194
   begin
195
      Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
196
   end Cancel_Protected_Entry_Call;
197
 
198
   ---------------
199
   -- Cancelled --
200
   ---------------
201
 
202
   function Cancelled (Block : Communication_Block) return Boolean is
203
   begin
204
      return Block.Cancelled;
205
   end Cancelled;
206
 
207
   -------------------------
208
   -- Complete_Entry_Body --
209
   -------------------------
210
 
211
   procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
212
   begin
213
      Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
214
   end Complete_Entry_Body;
215
 
216
   --------------
217
   -- Enqueued --
218
   --------------
219
 
220
   function Enqueued (Block : Communication_Block) return Boolean is
221
   begin
222
      return Block.Enqueued;
223
   end Enqueued;
224
 
225
   -------------------------------------
226
   -- Exceptional_Complete_Entry_Body --
227
   -------------------------------------
228
 
229
   procedure Exceptional_Complete_Entry_Body
230
     (Object : Protection_Entries_Access;
231
      Ex     : Ada.Exceptions.Exception_Id)
232
   is
233
      procedure Transfer_Occurrence
234
        (Target : Ada.Exceptions.Exception_Occurrence_Access;
235
         Source : Ada.Exceptions.Exception_Occurrence);
236
      pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
237
 
238
      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
239
      Self_Id    : Task_Id;
240
 
241
   begin
242
      pragma Debug
243
       (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
244
 
245
      --  We must have abort deferred, since we are inside a protected
246
      --  operation.
247
 
248
      if Entry_Call /= null then
249
 
250
         --  The call was not requeued
251
 
252
         Entry_Call.Exception_To_Raise := Ex;
253
 
254
         if Ex /= Ada.Exceptions.Null_Id then
255
 
256
            --  An exception was raised and abort was deferred, so adjust
257
            --  before propagating, otherwise the task will stay with deferral
258
            --  enabled for its remaining life.
259
 
260
            Self_Id := STPO.Self;
261
 
262
            if not ZCX_By_Default then
263
               Initialization.Undefer_Abort_Nestable (Self_Id);
264
            end if;
265
 
266
            Transfer_Occurrence
267
              (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
268
               Self_Id.Common.Compiler_Data.Current_Excep);
269
         end if;
270
 
271
         --  Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
272
         --  PO_Service_Entries on return.
273
 
274
      end if;
275
 
276
      if Runtime_Traces then
277
 
278
         --  ??? Entry_Call can be null
279
 
280
         Send_Trace_Info (PO_Done, Entry_Call.Self);
281
      end if;
282
   end Exceptional_Complete_Entry_Body;
283
 
284
   --------------------
285
   -- PO_Do_Or_Queue --
286
   --------------------
287
 
288
   procedure PO_Do_Or_Queue
289
     (Self_ID    : Task_Id;
290
      Object     : Protection_Entries_Access;
291
      Entry_Call : Entry_Call_Link)
292
   is
293
      E             : constant Protected_Entry_Index :=
294
                        Protected_Entry_Index (Entry_Call.E);
295
      Barrier_Value : Boolean;
296
 
297
   begin
298
      --  When the Action procedure for an entry body returns, it is either
299
      --  completed (having called [Exceptional_]Complete_Entry_Body) or it
300
      --  is queued, having executed a requeue statement.
301
 
302
      Barrier_Value :=
303
        Object.Entry_Bodies (
304
          Object.Find_Body_Index (Object.Compiler_Info, E)).
305
            Barrier (Object.Compiler_Info, E);
306
 
307
      if Barrier_Value then
308
 
309
         --  Not abortable while service is in progress
310
 
311
         if Entry_Call.State = Now_Abortable then
312
            Entry_Call.State := Was_Abortable;
313
         end if;
314
 
315
         Object.Call_In_Progress := Entry_Call;
316
 
317
         pragma Debug
318
          (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
319
         Object.Entry_Bodies (
320
           Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
321
             Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
322
 
323
         if Object.Call_In_Progress /= null then
324
 
325
            --  Body of current entry served call to completion
326
 
327
            Object.Call_In_Progress := null;
328
 
329
            if Single_Lock then
330
               STPO.Lock_RTS;
331
            end if;
332
 
333
            STPO.Write_Lock (Entry_Call.Self);
334
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
335
            STPO.Unlock (Entry_Call.Self);
336
 
337
            if Single_Lock then
338
               STPO.Unlock_RTS;
339
            end if;
340
 
341
         else
342
            Requeue_Call (Self_ID, Object, Entry_Call);
343
         end if;
344
 
345
      elsif Entry_Call.Mode /= Conditional_Call
346
        or else not Entry_Call.With_Abort
347
      then
348
 
349
         if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
350
              and then
351
            Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
352
              Queuing.Count_Waiting (Object.Entry_Queues (E))
353
         then
354
            --  This violates the Max_Entry_Queue_Length restriction,
355
            --  raise Program_Error.
356
 
357
            Entry_Call.Exception_To_Raise := Program_Error'Identity;
358
 
359
            if Single_Lock then
360
               STPO.Lock_RTS;
361
            end if;
362
 
363
            STPO.Write_Lock (Entry_Call.Self);
364
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
365
            STPO.Unlock (Entry_Call.Self);
366
 
367
            if Single_Lock then
368
               STPO.Unlock_RTS;
369
            end if;
370
         else
371
            Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
372
            Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
373
         end if;
374
      else
375
         --  Conditional_Call and With_Abort
376
 
377
         if Single_Lock then
378
            STPO.Lock_RTS;
379
         end if;
380
 
381
         STPO.Write_Lock (Entry_Call.Self);
382
         pragma Assert (Entry_Call.State >= Was_Abortable);
383
         Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
384
         STPO.Unlock (Entry_Call.Self);
385
 
386
         if Single_Lock then
387
            STPO.Unlock_RTS;
388
         end if;
389
      end if;
390
 
391
   exception
392
      when others =>
393
         Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
394
   end PO_Do_Or_Queue;
395
 
396
   ------------------------
397
   -- PO_Service_Entries --
398
   ------------------------
399
 
400
   procedure PO_Service_Entries
401
     (Self_ID       : Task_Id;
402
      Object        : Entries.Protection_Entries_Access;
403
      Unlock_Object : Boolean := True)
404
   is
405
      E          : Protected_Entry_Index;
406
      Caller     : Task_Id;
407
      Entry_Call : Entry_Call_Link;
408
 
409
   begin
410
      loop
411
         Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
412
 
413
         exit when Entry_Call = null;
414
 
415
         E := Protected_Entry_Index (Entry_Call.E);
416
 
417
         --  Not abortable while service is in progress
418
 
419
         if Entry_Call.State = Now_Abortable then
420
            Entry_Call.State := Was_Abortable;
421
         end if;
422
 
423
         Object.Call_In_Progress := Entry_Call;
424
 
425
         begin
426
            if Runtime_Traces then
427
               Send_Trace_Info (PO_Run, Self_ID,
428
                                Entry_Call.Self, Entry_Index (E));
429
            end if;
430
 
431
            pragma Debug
432
              (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
433
 
434
            Object.Entry_Bodies
435
              (Object.Find_Body_Index (Object.Compiler_Info, E)).Action
436
                (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
437
 
438
         exception
439
            when others =>
440
               Queuing.Broadcast_Program_Error
441
                 (Self_ID, Object, Entry_Call);
442
         end;
443
 
444
         if Object.Call_In_Progress = null then
445
            Requeue_Call (Self_ID, Object, Entry_Call);
446
            exit when Entry_Call.State = Cancelled;
447
 
448
         else
449
            Object.Call_In_Progress := null;
450
            Caller := Entry_Call.Self;
451
 
452
            if Single_Lock then
453
               STPO.Lock_RTS;
454
            end if;
455
 
456
            STPO.Write_Lock (Caller);
457
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
458
            STPO.Unlock (Caller);
459
 
460
            if Single_Lock then
461
               STPO.Unlock_RTS;
462
            end if;
463
         end if;
464
      end loop;
465
 
466
      if Unlock_Object then
467
         Unlock_Entries (Object);
468
      end if;
469
   end PO_Service_Entries;
470
 
471
   ---------------------
472
   -- Protected_Count --
473
   ---------------------
474
 
475
   function Protected_Count
476
     (Object : Protection_Entries'Class;
477
      E      : Protected_Entry_Index) return Natural
478
   is
479
   begin
480
      return Queuing.Count_Waiting (Object.Entry_Queues (E));
481
   end Protected_Count;
482
 
483
   --------------------------
484
   -- Protected_Entry_Call --
485
   --------------------------
486
 
487
   --  Compiler interface only (do not call from within the RTS)
488
 
489
   --  select r.e;
490
   --     ...A...
491
   --  else
492
   --     ...B...
493
   --  end select;
494
 
495
   --  declare
496
   --     X : protected_entry_index := 1;
497
   --     B85b : communication_block;
498
   --     communication_blockIP (B85b);
499
 
500
   --  begin
501
   --     protected_entry_call (rTV!(r)._object'unchecked_access, X,
502
   --       null_address, conditional_call, B85b, objectF => 0);
503
 
504
   --     if cancelled (B85b) then
505
   --        ...B...
506
   --     else
507
   --        ...A...
508
   --     end if;
509
   --  end;
510
 
511
   --  See also Cancel_Protected_Entry_Call for code expansion of asynchronous
512
   --  entry call.
513
 
514
   --  The initial part of this procedure does not need to lock the calling
515
   --  task's ATCB, up to the point where the call record first may be queued
516
   --  (PO_Do_Or_Queue), since before that no other task will have access to
517
   --  the record.
518
 
519
   --  If this is a call made inside of an abort deferred region, the call
520
   --  should be never abortable.
521
 
522
   --  If the call was not queued abortably, we need to wait until it is before
523
   --  proceeding with the abortable part.
524
 
525
   --  There are some heuristics here, just to save time for frequently
526
   --  occurring cases. For example, we check Initially_Abortable to try to
527
   --  avoid calling the procedure Wait_Until_Abortable, since the normal case
528
   --  for async. entry calls is to be queued abortably.
529
 
530
   --  Another heuristic uses the Block.Enqueued to try to avoid calling
531
   --  Cancel_Protected_Entry_Call if the call can be served immediately.
532
 
533
   procedure Protected_Entry_Call
534
     (Object              : Protection_Entries_Access;
535
      E                   : Protected_Entry_Index;
536
      Uninterpreted_Data  : System.Address;
537
      Mode                : Call_Modes;
538
      Block               : out Communication_Block)
539
   is
540
      Self_ID             : constant Task_Id := STPO.Self;
541
      Entry_Call          : Entry_Call_Link;
542
      Initially_Abortable : Boolean;
543
      Ceiling_Violation   : Boolean;
544
 
545
   begin
546
      pragma Debug
547
        (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
548
 
549
      if Runtime_Traces then
550
         Send_Trace_Info (PO_Call, Entry_Index (E));
551
      end if;
552
 
553
      if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
554
         raise Storage_Error with "not enough ATC nesting levels";
555
      end if;
556
 
557
      --  If pragma Detect_Blocking is active then Program_Error must be
558
      --  raised if this potentially blocking operation is called from a
559
      --  protected action.
560
 
561
      if Detect_Blocking
562
        and then Self_ID.Common.Protected_Action_Nesting > 0
563
      then
564
         raise Program_Error with "potentially blocking operation";
565
      end if;
566
 
567
      --  Self_ID.Deferral_Level should be 0, except when called from Finalize,
568
      --  where abort is already deferred.
569
 
570
      Initialization.Defer_Abort_Nestable (Self_ID);
571
      Lock_Entries_With_Status (Object, Ceiling_Violation);
572
 
573
      if Ceiling_Violation then
574
 
575
         --  Failed ceiling check
576
 
577
         Initialization.Undefer_Abort_Nestable (Self_ID);
578
         raise Program_Error;
579
      end if;
580
 
581
      Block.Self := Self_ID;
582
      Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
583
      pragma Debug
584
        (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
585
         ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
586
      Entry_Call :=
587
         Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
588
      Entry_Call.Next := null;
589
      Entry_Call.Mode := Mode;
590
      Entry_Call.Cancellation_Attempted := False;
591
 
592
      Entry_Call.State :=
593
        (if Self_ID.Deferral_Level > 1
594
         then Never_Abortable else Now_Abortable);
595
 
596
      Entry_Call.E := Entry_Index (E);
597
      Entry_Call.Prio := STPO.Get_Priority (Self_ID);
598
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
599
      Entry_Call.Called_PO := To_Address (Object);
600
      Entry_Call.Called_Task := null;
601
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
602
      Entry_Call.With_Abort := True;
603
 
604
      PO_Do_Or_Queue (Self_ID, Object, Entry_Call);
605
      Initially_Abortable := Entry_Call.State = Now_Abortable;
606
      PO_Service_Entries (Self_ID, Object);
607
 
608
      --  Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
609
      --  for completed or cancelled calls.  (This is a heuristic, only.)
610
 
611
      if Entry_Call.State >= Done then
612
 
613
         --  Once State >= Done it will not change any more
614
 
615
         if Single_Lock then
616
            STPO.Lock_RTS;
617
         end if;
618
 
619
         STPO.Write_Lock (Self_ID);
620
         Utilities.Exit_One_ATC_Level (Self_ID);
621
         STPO.Unlock (Self_ID);
622
 
623
         if Single_Lock then
624
            STPO.Unlock_RTS;
625
         end if;
626
 
627
         Block.Enqueued := False;
628
         Block.Cancelled := Entry_Call.State = Cancelled;
629
         Initialization.Undefer_Abort_Nestable (Self_ID);
630
         Entry_Calls.Check_Exception (Self_ID, Entry_Call);
631
         return;
632
 
633
      else
634
         --  In this case we cannot conclude anything, since State can change
635
         --  concurrently.
636
 
637
         null;
638
      end if;
639
 
640
      --  Now for the general case
641
 
642
      if Mode = Asynchronous_Call then
643
 
644
         --  Try to avoid an expensive call
645
 
646
         if not Initially_Abortable then
647
            if Single_Lock then
648
               STPO.Lock_RTS;
649
               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
650
               STPO.Unlock_RTS;
651
            else
652
               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
653
            end if;
654
         end if;
655
 
656
      else
657
         case Mode is
658
            when Simple_Call | Conditional_Call =>
659
               if Single_Lock then
660
                  STPO.Lock_RTS;
661
                  Entry_Calls.Wait_For_Completion (Entry_Call);
662
                  STPO.Unlock_RTS;
663
 
664
               else
665
                  STPO.Write_Lock (Self_ID);
666
                  Entry_Calls.Wait_For_Completion (Entry_Call);
667
                  STPO.Unlock (Self_ID);
668
               end if;
669
 
670
               Block.Cancelled := Entry_Call.State = Cancelled;
671
 
672
            when Asynchronous_Call | Timed_Call =>
673
               pragma Assert (False);
674
               null;
675
         end case;
676
      end if;
677
 
678
      Initialization.Undefer_Abort_Nestable (Self_ID);
679
      Entry_Calls.Check_Exception (Self_ID, Entry_Call);
680
   end Protected_Entry_Call;
681
 
682
   ------------------
683
   -- Requeue_Call --
684
   ------------------
685
 
686
   procedure Requeue_Call
687
     (Self_Id    : Task_Id;
688
      Object     : Protection_Entries_Access;
689
      Entry_Call : Entry_Call_Link)
690
   is
691
      New_Object        : Protection_Entries_Access;
692
      Ceiling_Violation : Boolean;
693
      Result            : Boolean;
694
      E                 : Protected_Entry_Index;
695
 
696
   begin
697
      New_Object := To_Protection (Entry_Call.Called_PO);
698
 
699
      if New_Object = null then
700
 
701
         --  Call is to be requeued to a task entry
702
 
703
         if Single_Lock then
704
            STPO.Lock_RTS;
705
         end if;
706
 
707
         Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);
708
 
709
         if not Result then
710
            Queuing.Broadcast_Program_Error
711
              (Self_Id, Object, Entry_Call, RTS_Locked => True);
712
         end if;
713
 
714
         if Single_Lock then
715
            STPO.Unlock_RTS;
716
         end if;
717
 
718
      else
719
         --  Call should be requeued to a PO
720
 
721
         if Object /= New_Object then
722
 
723
            --  Requeue is to different PO
724
 
725
            Lock_Entries_With_Status (New_Object, Ceiling_Violation);
726
 
727
            if Ceiling_Violation then
728
               Object.Call_In_Progress := null;
729
               Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);
730
 
731
            else
732
               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
733
               PO_Service_Entries (Self_Id, New_Object);
734
            end if;
735
 
736
         else
737
            --  Requeue is to same protected object
738
 
739
            --  ??? Try to compensate apparent failure of the scheduler on some
740
            --  OS (e.g VxWorks) to give higher priority tasks a chance to run
741
            --  (see CXD6002).
742
 
743
            STPO.Yield (Do_Yield => False);
744
 
745
            if Entry_Call.With_Abort
746
              and then Entry_Call.Cancellation_Attempted
747
            then
748
               --  If this is a requeue with abort and someone tried to cancel
749
               --  this call, cancel it at this point.
750
 
751
               Entry_Call.State := Cancelled;
752
               return;
753
            end if;
754
 
755
            if not Entry_Call.With_Abort
756
              or else Entry_Call.Mode /= Conditional_Call
757
            then
758
               E := Protected_Entry_Index (Entry_Call.E);
759
 
760
               if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
761
                    and then
762
                  Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
763
                    Queuing.Count_Waiting (Object.Entry_Queues (E))
764
               then
765
                  --  This violates the Max_Entry_Queue_Length restriction,
766
                  --  raise Program_Error.
767
 
768
                  Entry_Call.Exception_To_Raise := Program_Error'Identity;
769
 
770
                  if Single_Lock then
771
                     STPO.Lock_RTS;
772
                  end if;
773
 
774
                  STPO.Write_Lock (Entry_Call.Self);
775
                  Initialization.Wakeup_Entry_Caller
776
                    (Self_Id, Entry_Call, Done);
777
                  STPO.Unlock (Entry_Call.Self);
778
 
779
                  if Single_Lock then
780
                     STPO.Unlock_RTS;
781
                  end if;
782
 
783
               else
784
                  Queuing.Enqueue
785
                    (New_Object.Entry_Queues (E), Entry_Call);
786
                  Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
787
               end if;
788
 
789
            else
790
               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
791
            end if;
792
         end if;
793
      end if;
794
   end Requeue_Call;
795
 
796
   ----------------------------
797
   -- Protected_Entry_Caller --
798
   ----------------------------
799
 
800
   function Protected_Entry_Caller
801
     (Object : Protection_Entries'Class) return Task_Id is
802
   begin
803
      return Object.Call_In_Progress.Self;
804
   end Protected_Entry_Caller;
805
 
806
   -----------------------------
807
   -- Requeue_Protected_Entry --
808
   -----------------------------
809
 
810
   --  Compiler interface only (do not call from within the RTS)
811
 
812
   --  entry e when b is
813
   --  begin
814
   --     b := false;
815
   --     ...A...
816
   --     requeue e2;
817
   --  end e;
818
 
819
   --  procedure rPT__E10b (O : address; P : address; E :
820
   --    protected_entry_index) is
821
   --     type rTVP is access rTV;
822
   --     freeze rTVP []
823
   --     _object : rTVP := rTVP!(O);
824
   --  begin
825
   --     declare
826
   --        rR : protection renames _object._object;
827
   --        vP : integer renames _object.v;
828
   --        bP : boolean renames _object.b;
829
   --     begin
830
   --        b := false;
831
   --        ...A...
832
   --        requeue_protected_entry (rR'unchecked_access, rR'
833
   --          unchecked_access, 2, false, objectF => 0, new_objectF =>
834
   --          0);
835
   --        return;
836
   --     end;
837
   --     complete_entry_body (_object._object'unchecked_access, objectF =>
838
   --       0);
839
   --     return;
840
   --  exception
841
   --     when others =>
842
   --        abort_undefer.all;
843
   --        exceptional_complete_entry_body (_object._object'
844
   --          unchecked_access, current_exception, objectF => 0);
845
   --        return;
846
   --  end rPT__E10b;
847
 
848
   procedure Requeue_Protected_Entry
849
     (Object     : Protection_Entries_Access;
850
      New_Object : Protection_Entries_Access;
851
      E          : Protected_Entry_Index;
852
      With_Abort : Boolean)
853
   is
854
      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
855
 
856
   begin
857
      pragma Debug
858
        (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
859
      pragma Assert (STPO.Self.Deferral_Level > 0);
860
 
861
      Entry_Call.E := Entry_Index (E);
862
      Entry_Call.Called_PO := To_Address (New_Object);
863
      Entry_Call.Called_Task := null;
864
      Entry_Call.With_Abort := With_Abort;
865
      Object.Call_In_Progress := null;
866
   end Requeue_Protected_Entry;
867
 
868
   -------------------------------------
869
   -- Requeue_Task_To_Protected_Entry --
870
   -------------------------------------
871
 
872
   --  Compiler interface only (do not call from within the RTS)
873
 
874
   --    accept e1 do
875
   --      ...A...
876
   --      requeue r.e2;
877
   --    end e1;
878
 
879
   --    A79b : address;
880
   --    L78b : label
881
 
882
   --    begin
883
   --       accept_call (1, A79b);
884
   --       ...A...
885
   --       requeue_task_to_protected_entry (rTV!(r)._object'
886
   --         unchecked_access, 2, false, new_objectF => 0);
887
   --       goto L78b;
888
   --       <<L78b>>
889
   --       complete_rendezvous;
890
 
891
   --    exception
892
   --       when all others =>
893
   --          exceptional_complete_rendezvous (get_gnat_exception);
894
   --    end;
895
 
896
   procedure Requeue_Task_To_Protected_Entry
897
     (New_Object : Protection_Entries_Access;
898
      E          : Protected_Entry_Index;
899
      With_Abort : Boolean)
900
   is
901
      Self_ID    : constant Task_Id := STPO.Self;
902
      Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
903
 
904
   begin
905
      Initialization.Defer_Abort (Self_ID);
906
 
907
      --  We do not need to lock Self_ID here since the call is not abortable
908
      --  at this point, and therefore, the caller cannot cancel the call.
909
 
910
      Entry_Call.Needs_Requeue := True;
911
      Entry_Call.With_Abort := With_Abort;
912
      Entry_Call.Called_PO := To_Address (New_Object);
913
      Entry_Call.Called_Task := null;
914
      Entry_Call.E := Entry_Index (E);
915
      Initialization.Undefer_Abort (Self_ID);
916
   end Requeue_Task_To_Protected_Entry;
917
 
918
   ---------------------
919
   -- Service_Entries --
920
   ---------------------
921
 
922
   procedure Service_Entries (Object : Protection_Entries_Access) is
923
      Self_ID : constant Task_Id := STPO.Self;
924
   begin
925
      PO_Service_Entries (Self_ID, Object);
926
   end Service_Entries;
927
 
928
   --------------------------------
929
   -- Timed_Protected_Entry_Call --
930
   --------------------------------
931
 
932
   --  Compiler interface only (do not call from within the RTS)
933
 
934
   procedure Timed_Protected_Entry_Call
935
     (Object                : Protection_Entries_Access;
936
      E                     : Protected_Entry_Index;
937
      Uninterpreted_Data    : System.Address;
938
      Timeout               : Duration;
939
      Mode                  : Delay_Modes;
940
      Entry_Call_Successful : out Boolean)
941
   is
942
      Self_Id           : constant Task_Id  := STPO.Self;
943
      Entry_Call        : Entry_Call_Link;
944
      Ceiling_Violation : Boolean;
945
 
946
      Yielded : Boolean;
947
      pragma Unreferenced (Yielded);
948
 
949
   begin
950
      if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
951
         raise Storage_Error with "not enough ATC nesting levels";
952
      end if;
953
 
954
      --  If pragma Detect_Blocking is active then Program_Error must be
955
      --  raised if this potentially blocking operation is called from a
956
      --  protected action.
957
 
958
      if Detect_Blocking
959
        and then Self_Id.Common.Protected_Action_Nesting > 0
960
      then
961
         raise Program_Error with "potentially blocking operation";
962
      end if;
963
 
964
      if Runtime_Traces then
965
         Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
966
      end if;
967
 
968
      Initialization.Defer_Abort_Nestable (Self_Id);
969
      Lock_Entries_With_Status (Object, Ceiling_Violation);
970
 
971
      if Ceiling_Violation then
972
         Initialization.Undefer_Abort (Self_Id);
973
         raise Program_Error;
974
      end if;
975
 
976
      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
977
      pragma Debug
978
        (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
979
         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
980
      Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
981
      Entry_Call.Next := null;
982
      Entry_Call.Mode := Timed_Call;
983
      Entry_Call.Cancellation_Attempted := False;
984
 
985
      Entry_Call.State :=
986
        (if Self_Id.Deferral_Level > 1
987
         then Never_Abortable
988
         else Now_Abortable);
989
 
990
      Entry_Call.E := Entry_Index (E);
991
      Entry_Call.Prio := STPO.Get_Priority (Self_Id);
992
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
993
      Entry_Call.Called_PO := To_Address (Object);
994
      Entry_Call.Called_Task := null;
995
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
996
      Entry_Call.With_Abort := True;
997
 
998
      PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
999
      PO_Service_Entries (Self_Id, Object);
1000
 
1001
      if Single_Lock then
1002
         STPO.Lock_RTS;
1003
      else
1004
         STPO.Write_Lock (Self_Id);
1005
      end if;
1006
 
1007
      --  Try to avoid waiting for completed or cancelled calls
1008
 
1009
      if Entry_Call.State >= Done then
1010
         Utilities.Exit_One_ATC_Level (Self_Id);
1011
 
1012
         if Single_Lock then
1013
            STPO.Unlock_RTS;
1014
         else
1015
            STPO.Unlock (Self_Id);
1016
         end if;
1017
 
1018
         Entry_Call_Successful := Entry_Call.State = Done;
1019
         Initialization.Undefer_Abort_Nestable (Self_Id);
1020
         Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1021
         return;
1022
      end if;
1023
 
1024
      Entry_Calls.Wait_For_Completion_With_Timeout
1025
        (Entry_Call, Timeout, Mode, Yielded);
1026
 
1027
      if Single_Lock then
1028
         STPO.Unlock_RTS;
1029
      else
1030
         STPO.Unlock (Self_Id);
1031
      end if;
1032
 
1033
      --  ??? Do we need to yield in case Yielded is False
1034
 
1035
      Initialization.Undefer_Abort_Nestable (Self_Id);
1036
      Entry_Call_Successful := Entry_Call.State = Done;
1037
      Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1038
   end Timed_Protected_Entry_Call;
1039
 
1040
   ----------------------------
1041
   -- Update_For_Queue_To_PO --
1042
   ----------------------------
1043
 
1044
   --  Update the state of an existing entry call, based on
1045
   --  whether the current queuing action is with or without abort.
1046
   --  Call this only while holding the server's lock.
1047
   --  It returns with the server's lock released.
1048
 
1049
   New_State : constant array (Boolean, Entry_Call_State)
1050
     of Entry_Call_State :=
1051
       (True =>
1052
         (Never_Abortable   => Never_Abortable,
1053
          Not_Yet_Abortable => Now_Abortable,
1054
          Was_Abortable     => Now_Abortable,
1055
          Now_Abortable     => Now_Abortable,
1056
          Done              => Done,
1057
          Cancelled         => Cancelled),
1058
        False =>
1059
         (Never_Abortable   => Never_Abortable,
1060
          Not_Yet_Abortable => Not_Yet_Abortable,
1061
          Was_Abortable     => Was_Abortable,
1062
          Now_Abortable     => Now_Abortable,
1063
          Done              => Done,
1064
          Cancelled         => Cancelled)
1065
       );
1066
 
1067
   procedure Update_For_Queue_To_PO
1068
     (Entry_Call : Entry_Call_Link;
1069
      With_Abort : Boolean)
1070
   is
1071
      Old : constant Entry_Call_State := Entry_Call.State;
1072
 
1073
   begin
1074
      pragma Assert (Old < Done);
1075
 
1076
      Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1077
 
1078
      if Entry_Call.Mode = Asynchronous_Call then
1079
         if Old < Was_Abortable and then
1080
           Entry_Call.State = Now_Abortable
1081
         then
1082
            if Single_Lock then
1083
               STPO.Lock_RTS;
1084
            end if;
1085
 
1086
            STPO.Write_Lock (Entry_Call.Self);
1087
 
1088
            if Entry_Call.Self.Common.State = Async_Select_Sleep then
1089
               STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1090
            end if;
1091
 
1092
            STPO.Unlock (Entry_Call.Self);
1093
 
1094
            if Single_Lock then
1095
               STPO.Unlock_RTS;
1096
            end if;
1097
 
1098
         end if;
1099
 
1100
      elsif Entry_Call.Mode = Conditional_Call then
1101
         pragma Assert (Entry_Call.State < Was_Abortable);
1102
         null;
1103
      end if;
1104
   end Update_For_Queue_To_PO;
1105
 
1106
end System.Tasking.Protected_Objects.Operations;

powered by: WebSVN 2.1.0

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