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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tposen.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.SINGLE_ENTRY                --
6
--                                                                          --
7
--                                B o d y                                   --
8
--                                                                          --
9
--         Copyright (C) 1998-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
pragma Style_Checks (All_Checks);
33
--  Turn off subprogram ordering check, since restricted GNARLI subprograms are
34
--  gathered together at end.
35
 
36
--  This package provides an optimized version of Protected_Objects.Operations
37
--  and Protected_Objects.Entries making the following assumptions:
38
 
39
--    PO has only one entry
40
--    There is only one caller at a time (No_Entry_Queue)
41
--    There is no dynamic priority support (No_Dynamic_Priorities)
42
--    No Abort Statements
43
--     (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
44
--    PO are at library level
45
--    No Requeue
46
--    None of the tasks will terminate (no need for finalization)
47
 
48
--  This interface is intended to be used in the ravenscar and restricted
49
--  profiles, the compiler is responsible for ensuring that the conditions
50
--  mentioned above are respected, except for the No_Entry_Queue restriction
51
--  that is checked dynamically in this package, since the check cannot be
52
--  performed at compile time, and is relatively cheap (see PO_Do_Or_Queue,
53
--  Service_Entry).
54
 
55
pragma Polling (Off);
56
--  Turn off polling, we do not want polling to take place during tasking
57
--  operations. It can cause  infinite loops and other problems.
58
 
59
pragma Suppress (All_Checks);
60
--  Why is this required ???
61
 
62
with Ada.Exceptions;
63
 
64
with System.Task_Primitives.Operations;
65
with System.Parameters;
66
 
67
package body System.Tasking.Protected_Objects.Single_Entry is
68
 
69
   package STPO renames System.Task_Primitives.Operations;
70
 
71
   use Parameters;
72
 
73
   -----------------------
74
   -- Local Subprograms --
75
   -----------------------
76
 
77
   procedure Send_Program_Error
78
     (Self_Id    : Task_Id;
79
      Entry_Call : Entry_Call_Link);
80
   pragma Inline (Send_Program_Error);
81
   --  Raise Program_Error in the caller of the specified entry call
82
 
83
   --------------------------
84
   -- Entry Calls Handling --
85
   --------------------------
86
 
87
   procedure Wakeup_Entry_Caller
88
     (Self_ID    : Task_Id;
89
      Entry_Call : Entry_Call_Link;
90
      New_State  : Entry_Call_State);
91
   pragma Inline (Wakeup_Entry_Caller);
92
   --  This is called at the end of service of an entry call,
93
   --  to abort the caller if he is in an abortable part, and
94
   --  to wake up the caller if he is on Entry_Caller_Sleep.
95
   --  Call it holding the lock of Entry_Call.Self.
96
   --
97
   --  Timed_Call or Simple_Call:
98
   --    The caller is waiting on Entry_Caller_Sleep, in
99
   --    Wait_For_Completion, or Wait_For_Completion_With_Timeout.
100
 
101
   procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
102
   pragma Inline (Wait_For_Completion);
103
   --  This procedure suspends the calling task until the specified entry call
104
   --  has either been completed or cancelled. On exit, the call will not be
105
   --  queued. This waits for calls on protected entries.
106
   --  Call this only when holding Self_ID locked.
107
 
108
   procedure Wait_For_Completion_With_Timeout
109
     (Entry_Call  : Entry_Call_Link;
110
      Wakeup_Time : Duration;
111
      Mode        : Delay_Modes);
112
   --  Same as Wait_For_Completion but it waits for a timeout with the value
113
   --  specified in Wakeup_Time as well.
114
 
115
   procedure Check_Exception
116
     (Self_ID : Task_Id;
117
      Entry_Call : Entry_Call_Link);
118
   pragma Inline (Check_Exception);
119
   --  Raise any pending exception from the Entry_Call.
120
   --  This should be called at the end of every compiler interface procedure
121
   --  that implements an entry call.
122
   --  The caller should not be holding any locks, or there will be deadlock.
123
 
124
   procedure PO_Do_Or_Queue
125
     (Self_Id    : Task_Id;
126
      Object     : Protection_Entry_Access;
127
      Entry_Call : Entry_Call_Link);
128
   --  This procedure executes or queues an entry call, depending
129
   --  on the status of the corresponding barrier. It assumes that the
130
   --  specified object is locked.
131
 
132
   ---------------------
133
   -- Check_Exception --
134
   ---------------------
135
 
136
   procedure Check_Exception
137
     (Self_ID    : Task_Id;
138
      Entry_Call : Entry_Call_Link)
139
   is
140
      pragma Warnings (Off, Self_ID);
141
 
142
      procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
143
      pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
144
 
145
      use type Ada.Exceptions.Exception_Id;
146
 
147
      E : constant Ada.Exceptions.Exception_Id :=
148
            Entry_Call.Exception_To_Raise;
149
 
150
   begin
151
      if E /= Ada.Exceptions.Null_Id then
152
         Internal_Raise (E);
153
      end if;
154
   end Check_Exception;
155
 
156
   ------------------------
157
   -- Send_Program_Error --
158
   ------------------------
159
 
160
   procedure Send_Program_Error
161
     (Self_Id    : Task_Id;
162
      Entry_Call : Entry_Call_Link)
163
   is
164
      Caller : constant Task_Id := Entry_Call.Self;
165
   begin
166
      Entry_Call.Exception_To_Raise := Program_Error'Identity;
167
 
168
      if Single_Lock then
169
         STPO.Lock_RTS;
170
      end if;
171
 
172
      STPO.Write_Lock (Caller);
173
      Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
174
      STPO.Unlock (Caller);
175
 
176
      if Single_Lock then
177
         STPO.Unlock_RTS;
178
      end if;
179
   end Send_Program_Error;
180
 
181
   -------------------------
182
   -- Wait_For_Completion --
183
   -------------------------
184
 
185
   procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
186
      Self_Id : constant Task_Id := Entry_Call.Self;
187
   begin
188
      Self_Id.Common.State := Entry_Caller_Sleep;
189
      STPO.Sleep (Self_Id, Entry_Caller_Sleep);
190
      Self_Id.Common.State := Runnable;
191
   end Wait_For_Completion;
192
 
193
   --------------------------------------
194
   -- Wait_For_Completion_With_Timeout --
195
   --------------------------------------
196
 
197
   procedure Wait_For_Completion_With_Timeout
198
     (Entry_Call  : Entry_Call_Link;
199
      Wakeup_Time : Duration;
200
      Mode        : Delay_Modes)
201
   is
202
      Self_Id  : constant Task_Id := Entry_Call.Self;
203
      Timedout : Boolean;
204
 
205
      Yielded  : Boolean;
206
      pragma Unreferenced (Yielded);
207
 
208
      use type Ada.Exceptions.Exception_Id;
209
 
210
   begin
211
      --  This procedure waits for the entry call to be served, with a timeout.
212
      --  It tries to cancel the call if the timeout expires before the call is
213
      --  served.
214
 
215
      --  If we wake up from the timed sleep operation here, it may be for the
216
      --  following possible reasons:
217
 
218
      --  1) The entry call is done being served.
219
      --  2) The timeout has expired (Timedout = True)
220
 
221
      --  Once the timeout has expired we may need to continue to wait if the
222
      --  call is already being serviced. In that case, we want to go back to
223
      --  sleep, but without any timeout. The variable Timedout is used to
224
      --  control this. If the Timedout flag is set, we do not need to Sleep
225
      --  with a timeout. We just sleep until we get a wakeup for some status
226
      --  change.
227
 
228
      pragma Assert (Entry_Call.Mode = Timed_Call);
229
      Self_Id.Common.State := Entry_Caller_Sleep;
230
 
231
      STPO.Timed_Sleep
232
        (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
233
 
234
      Entry_Call.State := (if Timedout then Cancelled else Done);
235
      Self_Id.Common.State := Runnable;
236
   end Wait_For_Completion_With_Timeout;
237
 
238
   -------------------------
239
   -- Wakeup_Entry_Caller --
240
   -------------------------
241
 
242
   --  This is called at the end of service of an entry call, to abort the
243
   --  caller if he is in an abortable part, and to wake up the caller if it
244
   --  is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
245
 
246
   --  (This enforces the rule that a task must be off-queue if its state is
247
   --  Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
248
 
249
   --  Timed_Call or Simple_Call:
250
   --    The caller is waiting on Entry_Caller_Sleep, in
251
   --    Wait_For_Completion, or Wait_For_Completion_With_Timeout.
252
 
253
   --  Conditional_Call:
254
   --    The caller might be in Wait_For_Completion,
255
   --    waiting for a rendezvous (possibly requeued without abort)
256
   --    to complete.
257
 
258
   procedure Wakeup_Entry_Caller
259
     (Self_ID    : Task_Id;
260
      Entry_Call : Entry_Call_Link;
261
      New_State  : Entry_Call_State)
262
   is
263
      pragma Warnings (Off, Self_ID);
264
 
265
      Caller : constant Task_Id := Entry_Call.Self;
266
 
267
   begin
268
      pragma Assert (New_State = Done or else New_State = Cancelled);
269
      pragma Assert
270
        (Caller.Common.State /= Terminated and then
271
         Caller.Common.State /= Unactivated);
272
 
273
      Entry_Call.State := New_State;
274
      STPO.Wakeup (Caller, Entry_Caller_Sleep);
275
   end Wakeup_Entry_Caller;
276
 
277
   -----------------------
278
   -- Restricted GNARLI --
279
   -----------------------
280
 
281
   --------------------------------
282
   -- Complete_Single_Entry_Body --
283
   --------------------------------
284
 
285
   procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is
286
      pragma Warnings (Off, Object);
287
 
288
   begin
289
      --  Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
290
      --  has already been set to Null_Id).
291
 
292
      null;
293
   end Complete_Single_Entry_Body;
294
 
295
   --------------------------------------------
296
   -- Exceptional_Complete_Single_Entry_Body --
297
   --------------------------------------------
298
 
299
   procedure Exceptional_Complete_Single_Entry_Body
300
     (Object : Protection_Entry_Access;
301
      Ex     : Ada.Exceptions.Exception_Id) is
302
   begin
303
      Object.Call_In_Progress.Exception_To_Raise := Ex;
304
   end Exceptional_Complete_Single_Entry_Body;
305
 
306
   ---------------------------------
307
   -- Initialize_Protection_Entry --
308
   ---------------------------------
309
 
310
   procedure Initialize_Protection_Entry
311
     (Object            : Protection_Entry_Access;
312
      Ceiling_Priority  : Integer;
313
      Compiler_Info     : System.Address;
314
      Entry_Body        : Entry_Body_Access)
315
   is
316
   begin
317
      Initialize_Protection (Object.Common'Access, Ceiling_Priority);
318
 
319
      Object.Compiler_Info := Compiler_Info;
320
      Object.Call_In_Progress := null;
321
      Object.Entry_Body := Entry_Body;
322
      Object.Entry_Queue := null;
323
   end Initialize_Protection_Entry;
324
 
325
   ----------------
326
   -- Lock_Entry --
327
   ----------------
328
 
329
   --  Compiler interface only.
330
   --  Do not call this procedure from within the run-time system.
331
 
332
   procedure Lock_Entry (Object : Protection_Entry_Access) is
333
   begin
334
      Lock (Object.Common'Access);
335
   end Lock_Entry;
336
 
337
   --------------------------
338
   -- Lock_Read_Only_Entry --
339
   --------------------------
340
 
341
   --  Compiler interface only
342
 
343
   --  Do not call this procedure from within the runtime system
344
 
345
   procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
346
   begin
347
      Lock_Read_Only (Object.Common'Access);
348
   end Lock_Read_Only_Entry;
349
 
350
   --------------------
351
   -- PO_Do_Or_Queue --
352
   --------------------
353
 
354
   procedure PO_Do_Or_Queue
355
     (Self_Id    : Task_Id;
356
      Object     : Protection_Entry_Access;
357
      Entry_Call : Entry_Call_Link)
358
   is
359
      Barrier_Value : Boolean;
360
 
361
   begin
362
      --  When the Action procedure for an entry body returns, it must be
363
      --  completed (having called [Exceptional_]Complete_Entry_Body).
364
 
365
      Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
366
 
367
      if Barrier_Value then
368
         if Object.Call_In_Progress /= null then
369
 
370
            --  This violates the No_Entry_Queue restriction, send
371
            --  Program_Error to the caller.
372
 
373
            Send_Program_Error (Self_Id, Entry_Call);
374
            return;
375
         end if;
376
 
377
         Object.Call_In_Progress := Entry_Call;
378
         Object.Entry_Body.Action
379
           (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
380
         Object.Call_In_Progress := null;
381
 
382
         if Single_Lock then
383
            STPO.Lock_RTS;
384
         end if;
385
 
386
         STPO.Write_Lock (Entry_Call.Self);
387
         Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
388
         STPO.Unlock (Entry_Call.Self);
389
 
390
         if Single_Lock then
391
            STPO.Unlock_RTS;
392
         end if;
393
 
394
      elsif Entry_Call.Mode /= Conditional_Call then
395
         if Object.Entry_Queue /= null then
396
 
397
            --  This violates the No_Entry_Queue restriction, send
398
            --  Program_Error to the caller.
399
 
400
            Send_Program_Error (Self_Id, Entry_Call);
401
            return;
402
         else
403
            Object.Entry_Queue := Entry_Call;
404
         end if;
405
 
406
      else
407
         --  Conditional_Call
408
 
409
         if Single_Lock then
410
            STPO.Lock_RTS;
411
         end if;
412
 
413
         STPO.Write_Lock (Entry_Call.Self);
414
         Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
415
         STPO.Unlock (Entry_Call.Self);
416
 
417
         if Single_Lock then
418
            STPO.Unlock_RTS;
419
         end if;
420
      end if;
421
 
422
   exception
423
      when others =>
424
         Send_Program_Error
425
           (Self_Id, Entry_Call);
426
   end PO_Do_Or_Queue;
427
 
428
   ----------------------------
429
   -- Protected_Single_Count --
430
   ----------------------------
431
 
432
   function Protected_Count_Entry (Object : Protection_Entry) return Natural is
433
   begin
434
      if Object.Entry_Queue /= null then
435
         return 1;
436
      else
437
         return 0;
438
      end if;
439
   end Protected_Count_Entry;
440
 
441
   ---------------------------------
442
   -- Protected_Single_Entry_Call --
443
   ---------------------------------
444
 
445
   procedure Protected_Single_Entry_Call
446
     (Object             : Protection_Entry_Access;
447
      Uninterpreted_Data : System.Address;
448
      Mode               : Call_Modes)
449
   is
450
      Self_Id    : constant Task_Id := STPO.Self;
451
      Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
452
   begin
453
      --  If pragma Detect_Blocking is active then Program_Error must be
454
      --  raised if this potentially blocking operation is called from a
455
      --  protected action.
456
 
457
      if Detect_Blocking
458
        and then Self_Id.Common.Protected_Action_Nesting > 0
459
      then
460
         raise Program_Error with "potentially blocking operation";
461
      end if;
462
 
463
      Lock_Entry (Object);
464
 
465
      Entry_Call.Mode := Mode;
466
      Entry_Call.State := Now_Abortable;
467
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
468
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
469
 
470
      PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
471
      Unlock_Entry (Object);
472
 
473
      --  The call is either `Done' or not. It cannot be cancelled since there
474
      --  is no ATC construct.
475
 
476
      pragma Assert (Entry_Call.State /= Cancelled);
477
 
478
      if Entry_Call.State /= Done then
479
         if Single_Lock then
480
            STPO.Lock_RTS;
481
         end if;
482
 
483
         STPO.Write_Lock (Self_Id);
484
         Wait_For_Completion (Entry_Call'Access);
485
         STPO.Unlock (Self_Id);
486
 
487
         if Single_Lock then
488
            STPO.Unlock_RTS;
489
         end if;
490
      end if;
491
 
492
      Check_Exception (Self_Id, Entry_Call'Access);
493
   end Protected_Single_Entry_Call;
494
 
495
   -----------------------------------
496
   -- Protected_Single_Entry_Caller --
497
   -----------------------------------
498
 
499
   function Protected_Single_Entry_Caller
500
     (Object : Protection_Entry) return Task_Id is
501
   begin
502
      return Object.Call_In_Progress.Self;
503
   end Protected_Single_Entry_Caller;
504
 
505
   -------------------
506
   -- Service_Entry --
507
   -------------------
508
 
509
   procedure Service_Entry (Object : Protection_Entry_Access) is
510
      Self_Id    : constant Task_Id := STPO.Self;
511
      Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
512
      Caller     : Task_Id;
513
 
514
   begin
515
      if Entry_Call /= null
516
        and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
517
      then
518
         Object.Entry_Queue := null;
519
 
520
         if Object.Call_In_Progress /= null then
521
 
522
            --  Violation of No_Entry_Queue restriction, raise exception
523
 
524
            Send_Program_Error (Self_Id, Entry_Call);
525
            Unlock_Entry (Object);
526
            return;
527
         end if;
528
 
529
         Object.Call_In_Progress := Entry_Call;
530
         Object.Entry_Body.Action
531
           (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
532
         Object.Call_In_Progress := null;
533
         Caller := Entry_Call.Self;
534
         Unlock_Entry (Object);
535
 
536
         if Single_Lock then
537
            STPO.Lock_RTS;
538
         end if;
539
 
540
         STPO.Write_Lock (Caller);
541
         Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
542
         STPO.Unlock (Caller);
543
 
544
         if Single_Lock then
545
            STPO.Unlock_RTS;
546
         end if;
547
 
548
      else
549
         --  Just unlock the entry
550
 
551
         Unlock_Entry (Object);
552
      end if;
553
 
554
   exception
555
      when others =>
556
         Send_Program_Error (Self_Id, Entry_Call);
557
         Unlock_Entry (Object);
558
   end Service_Entry;
559
 
560
   ---------------------------------------
561
   -- Timed_Protected_Single_Entry_Call --
562
   ---------------------------------------
563
 
564
   --  Compiler interface only (do not call from within the RTS)
565
 
566
   procedure Timed_Protected_Single_Entry_Call
567
     (Object                : Protection_Entry_Access;
568
      Uninterpreted_Data    : System.Address;
569
      Timeout               : Duration;
570
      Mode                  : Delay_Modes;
571
      Entry_Call_Successful : out Boolean)
572
   is
573
      Self_Id           : constant Task_Id  := STPO.Self;
574
      Entry_Call        : Entry_Call_Record renames Self_Id.Entry_Calls (1);
575
 
576
   begin
577
      --  If pragma Detect_Blocking is active then Program_Error must be
578
      --  raised if this potentially blocking operation is called from a
579
      --  protected action.
580
 
581
      if Detect_Blocking
582
        and then Self_Id.Common.Protected_Action_Nesting > 0
583
      then
584
         raise Program_Error with "potentially blocking operation";
585
      end if;
586
 
587
      Lock (Object.Common'Access);
588
 
589
      Entry_Call.Mode := Timed_Call;
590
      Entry_Call.State := Now_Abortable;
591
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
592
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
593
 
594
      PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
595
      Unlock_Entry (Object);
596
 
597
      --  Try to avoid waiting for completed calls.
598
      --  The call is either `Done' or not. It cannot be cancelled since there
599
      --  is no ATC construct and the timed wait has not started yet.
600
 
601
      pragma Assert (Entry_Call.State /= Cancelled);
602
 
603
      if Entry_Call.State = Done then
604
         Check_Exception (Self_Id, Entry_Call'Access);
605
         Entry_Call_Successful := True;
606
         return;
607
      end if;
608
 
609
      if Single_Lock then
610
         STPO.Lock_RTS;
611
      else
612
         STPO.Write_Lock (Self_Id);
613
      end if;
614
 
615
      Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
616
 
617
      if Single_Lock then
618
         STPO.Unlock_RTS;
619
      else
620
         STPO.Unlock (Self_Id);
621
      end if;
622
 
623
      pragma Assert (Entry_Call.State >= Done);
624
 
625
      Check_Exception (Self_Id, Entry_Call'Access);
626
      Entry_Call_Successful := Entry_Call.State = Done;
627
   end Timed_Protected_Single_Entry_Call;
628
 
629
   ------------------
630
   -- Unlock_Entry --
631
   ------------------
632
 
633
   procedure Unlock_Entry (Object : Protection_Entry_Access) is
634
   begin
635
      Unlock (Object.Common'Access);
636
   end Unlock_Entry;
637
 
638
end System.Tasking.Protected_Objects.Single_Entry;

powered by: WebSVN 2.1.0

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