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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-taasde.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
--           S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S          --
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 Polling (Off);
33
--  Turn off polling, we do not want ATC polling to take place during
34
--  tasking operations. It causes infinite loops and other problems.
35
 
36
with Ada.Unchecked_Conversion;
37
with Ada.Task_Identification;
38
 
39
with System.Task_Primitives.Operations;
40
with System.Tasking.Utilities;
41
with System.Tasking.Initialization;
42
with System.Tasking.Debug;
43
with System.OS_Primitives;
44
with System.Interrupt_Management.Operations;
45
with System.Parameters;
46
with System.Traces.Tasking;
47
 
48
package body System.Tasking.Async_Delays is
49
 
50
   package STPO renames System.Task_Primitives.Operations;
51
   package ST renames System.Tasking;
52
   package STU renames System.Tasking.Utilities;
53
   package STI renames System.Tasking.Initialization;
54
   package OSP renames System.OS_Primitives;
55
 
56
   use Parameters;
57
   use System.Traces;
58
   use System.Traces.Tasking;
59
 
60
   function To_System is new Ada.Unchecked_Conversion
61
     (Ada.Task_Identification.Task_Id, Task_Id);
62
 
63
   Timer_Server_ID : ST.Task_Id;
64
 
65
   Timer_Attention : Boolean := False;
66
   pragma Atomic (Timer_Attention);
67
 
68
   task Timer_Server is
69
      pragma Interrupt_Priority (System.Any_Priority'Last);
70
   end Timer_Server;
71
 
72
   --  The timer queue is a circular doubly linked list, ordered by absolute
73
   --  wakeup time. The first item in the queue is Timer_Queue.Succ.
74
   --  It is given a Resume_Time that is larger than any legitimate wakeup
75
   --  time, so that the ordered insertion will always stop searching when it
76
   --  gets back to the queue header block.
77
 
78
   Timer_Queue : aliased Delay_Block;
79
 
80
   ------------------------
81
   -- Cancel_Async_Delay --
82
   ------------------------
83
 
84
   --  This should (only) be called from the compiler-generated cleanup routine
85
   --  for an async. select statement with delay statement as trigger. The
86
   --  effect should be to remove the delay from the timer queue, and exit one
87
   --  ATC nesting level.
88
   --  The usage and logic are similar to Cancel_Protected_Entry_Call, but
89
   --  simplified because this is not a true entry call.
90
 
91
   procedure Cancel_Async_Delay (D : Delay_Block_Access) is
92
      Dpred : Delay_Block_Access;
93
      Dsucc : Delay_Block_Access;
94
 
95
   begin
96
      --  Note that we mark the delay as being cancelled
97
      --  using a level value that is reserved.
98
 
99
      --  make this operation idempotent
100
 
101
      if D.Level = ATC_Level_Infinity then
102
         return;
103
      end if;
104
 
105
      D.Level := ATC_Level_Infinity;
106
 
107
      --  remove self from timer queue
108
 
109
      STI.Defer_Abort_Nestable (D.Self_Id);
110
 
111
      if Single_Lock then
112
         STPO.Lock_RTS;
113
      end if;
114
 
115
      STPO.Write_Lock (Timer_Server_ID);
116
      Dpred := D.Pred;
117
      Dsucc := D.Succ;
118
      Dpred.Succ := Dsucc;
119
      Dsucc.Pred := Dpred;
120
      D.Succ := D;
121
      D.Pred := D;
122
      STPO.Unlock (Timer_Server_ID);
123
 
124
      --  Note that the above deletion code is required to be
125
      --  idempotent, since the block may have been dequeued
126
      --  previously by the Timer_Server.
127
 
128
      --  leave the asynchronous select
129
 
130
      STPO.Write_Lock (D.Self_Id);
131
      STU.Exit_One_ATC_Level (D.Self_Id);
132
      STPO.Unlock (D.Self_Id);
133
 
134
      if Single_Lock then
135
         STPO.Unlock_RTS;
136
      end if;
137
 
138
      STI.Undefer_Abort_Nestable (D.Self_Id);
139
   end Cancel_Async_Delay;
140
 
141
   ---------------------------
142
   -- Enqueue_Time_Duration --
143
   ---------------------------
144
 
145
   function Enqueue_Duration
146
     (T : Duration;
147
      D : Delay_Block_Access) return Boolean
148
   is
149
   begin
150
      if T <= 0.0 then
151
         D.Timed_Out := True;
152
         STPO.Yield;
153
         return False;
154
 
155
      else
156
         --  The corresponding call to Undefer_Abort is performed by the
157
         --  expanded code (see exp_ch9).
158
 
159
         STI.Defer_Abort (STPO.Self);
160
         Time_Enqueue
161
           (STPO.Monotonic_Clock
162
            + Duration'Min (T, OSP.Max_Sensible_Delay), D);
163
         return True;
164
      end if;
165
   end Enqueue_Duration;
166
 
167
   ------------------
168
   -- Time_Enqueue --
169
   ------------------
170
 
171
   --  Allocate a queue element for the wakeup time T and put it in the
172
   --  queue in wakeup time order.  Assume we are on an asynchronous
173
   --  select statement with delay trigger.  Put the calling task to
174
   --  sleep until either the delay expires or is cancelled.
175
 
176
   --  We use one entry call record for this delay, since we have
177
   --  to increment the ATC nesting level, but since it is not a
178
   --  real entry call we do not need to use any of the fields of
179
   --  the call record.  The following code implements a subset of
180
   --  the actions for the asynchronous case of Protected_Entry_Call,
181
   --  much simplified since we know this never blocks, and does not
182
   --  have the full semantics of a protected entry call.
183
 
184
   procedure Time_Enqueue
185
     (T : Duration;
186
      D : Delay_Block_Access)
187
   is
188
      Self_Id : constant Task_Id  := STPO.Self;
189
      Q       : Delay_Block_Access;
190
 
191
      use type ST.Task_Id;
192
      --  for visibility of operator "="
193
 
194
   begin
195
      pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
196
      pragma Assert (Self_Id.Deferral_Level = 1,
197
        "async delay from within abort-deferred region");
198
 
199
      if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
200
         raise Storage_Error with "not enough ATC nesting levels";
201
      end if;
202
 
203
      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
204
 
205
      pragma Debug
206
        (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
207
         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
208
 
209
      D.Level := Self_Id.ATC_Nesting_Level;
210
      D.Self_Id := Self_Id;
211
      D.Resume_Time := T;
212
 
213
      if Single_Lock then
214
         STPO.Lock_RTS;
215
      end if;
216
 
217
      STPO.Write_Lock (Timer_Server_ID);
218
 
219
      --  Previously, there was code here to dynamically create
220
      --  the Timer_Server task, if one did not already exist.
221
      --  That code had a timing window that could allow multiple
222
      --  timer servers to be created. Luckily, the need for
223
      --  postponing creation of the timer server should now be
224
      --  gone, since this package will only be linked in if
225
      --  there are calls to enqueue calls on the timer server.
226
 
227
      --  Insert D in the timer queue, at the position determined
228
      --  by the wakeup time T.
229
 
230
      Q := Timer_Queue.Succ;
231
 
232
      while Q.Resume_Time < T loop
233
         Q := Q.Succ;
234
      end loop;
235
 
236
      --  Q is the block that has Resume_Time equal to or greater than
237
      --  T. After the insertion we want Q to be the successor of D.
238
 
239
      D.Succ := Q;
240
      D.Pred := Q.Pred;
241
      D.Pred.Succ := D;
242
      Q.Pred := D;
243
 
244
      --  If the new element became the head of the queue,
245
      --  signal the Timer_Server to wake up.
246
 
247
      if Timer_Queue.Succ = D then
248
         Timer_Attention := True;
249
         STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
250
      end if;
251
 
252
      STPO.Unlock (Timer_Server_ID);
253
 
254
      if Single_Lock then
255
         STPO.Unlock_RTS;
256
      end if;
257
   end Time_Enqueue;
258
 
259
   ---------------
260
   -- Timed_Out --
261
   ---------------
262
 
263
   function Timed_Out (D : Delay_Block_Access) return Boolean is
264
   begin
265
      return D.Timed_Out;
266
   end Timed_Out;
267
 
268
   ------------------
269
   -- Timer_Server --
270
   ------------------
271
 
272
   task body Timer_Server is
273
      function Get_Next_Wakeup_Time return Duration;
274
      --  Used to initialize Next_Wakeup_Time, but also to ensure that
275
      --  Make_Independent is called during the elaboration of this task.
276
 
277
      --------------------------
278
      -- Get_Next_Wakeup_Time --
279
      --------------------------
280
 
281
      function Get_Next_Wakeup_Time return Duration is
282
      begin
283
         STU.Make_Independent;
284
         return Duration'Last;
285
      end Get_Next_Wakeup_Time;
286
 
287
      --  Local Declarations
288
 
289
      Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time;
290
      Timedout         : Boolean;
291
      Yielded          : Boolean;
292
      Now              : Duration;
293
      Dequeued         : Delay_Block_Access;
294
      Dequeued_Task    : Task_Id;
295
 
296
      pragma Unreferenced (Timedout, Yielded);
297
 
298
   begin
299
      Timer_Server_ID := STPO.Self;
300
 
301
      --  Since this package may be elaborated before System.Interrupt,
302
      --  we need to call Setup_Interrupt_Mask explicitly to ensure that
303
      --  this task has the proper signal mask.
304
 
305
      Interrupt_Management.Operations.Setup_Interrupt_Mask;
306
 
307
      --  Initialize the timer queue to empty, and make the wakeup time of the
308
      --  header node be larger than any real wakeup time we will ever use.
309
 
310
      loop
311
         STI.Defer_Abort (Timer_Server_ID);
312
 
313
         if Single_Lock then
314
            STPO.Lock_RTS;
315
         end if;
316
 
317
         STPO.Write_Lock (Timer_Server_ID);
318
 
319
         --  The timer server needs to catch pending aborts after finalization
320
         --  of library packages. If it doesn't poll for it, the server will
321
         --  sometimes hang.
322
 
323
         if not Timer_Attention then
324
            Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
325
 
326
            if Next_Wakeup_Time = Duration'Last then
327
               Timer_Server_ID.User_State := 1;
328
               Next_Wakeup_Time :=
329
                 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
330
 
331
            else
332
               Timer_Server_ID.User_State := 2;
333
            end if;
334
 
335
            STPO.Timed_Sleep
336
              (Timer_Server_ID, Next_Wakeup_Time,
337
               OSP.Absolute_RT, ST.Timer_Server_Sleep,
338
               Timedout, Yielded);
339
            Timer_Server_ID.Common.State := ST.Runnable;
340
         end if;
341
 
342
         --  Service all of the wakeup requests on the queue whose times have
343
         --  been reached, and update Next_Wakeup_Time to next wakeup time
344
         --  after that (the wakeup time of the head of the queue if any, else
345
         --  a time far in the future).
346
 
347
         Timer_Server_ID.User_State := 3;
348
         Timer_Attention := False;
349
 
350
         Now := STPO.Monotonic_Clock;
351
         while Timer_Queue.Succ.Resume_Time <= Now loop
352
 
353
            --  Dequeue the waiting task from the front of the queue
354
 
355
            pragma Debug (System.Tasking.Debug.Trace
356
              (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
357
 
358
            Dequeued := Timer_Queue.Succ;
359
            Timer_Queue.Succ := Dequeued.Succ;
360
            Dequeued.Succ.Pred := Dequeued.Pred;
361
            Dequeued.Succ := Dequeued;
362
            Dequeued.Pred := Dequeued;
363
 
364
            --  We want to abort the queued task to the level of the async.
365
            --  select statement with the delay. To do that, we need to lock
366
            --  the ATCB of that task, but to avoid deadlock we need to release
367
            --  the lock of the Timer_Server. This leaves a window in which
368
            --  another task might perform an enqueue or dequeue operation on
369
            --  the timer queue, but that is OK because we always restart the
370
            --  next iteration at the head of the queue.
371
 
372
            if Parameters.Runtime_Traces then
373
               Send_Trace_Info (E_Kill, Dequeued.Self_Id);
374
            end if;
375
 
376
            STPO.Unlock (Timer_Server_ID);
377
            STPO.Write_Lock (Dequeued.Self_Id);
378
            Dequeued_Task := Dequeued.Self_Id;
379
            Dequeued.Timed_Out := True;
380
            STI.Locked_Abort_To_Level
381
              (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
382
            STPO.Unlock (Dequeued_Task);
383
            STPO.Write_Lock (Timer_Server_ID);
384
         end loop;
385
 
386
         Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
387
 
388
         --  Service returns the Next_Wakeup_Time.
389
         --  The Next_Wakeup_Time is either an infinity (no delay request)
390
         --  or the wakeup time of the queue head. This value is used for
391
         --  an actual delay in this server.
392
 
393
         STPO.Unlock (Timer_Server_ID);
394
 
395
         if Single_Lock then
396
            STPO.Unlock_RTS;
397
         end if;
398
 
399
         STI.Undefer_Abort (Timer_Server_ID);
400
      end loop;
401
   end Timer_Server;
402
 
403
   ------------------------------
404
   -- Package Body Elaboration --
405
   ------------------------------
406
 
407
begin
408
   Timer_Queue.Succ := Timer_Queue'Access;
409
   Timer_Queue.Pred := Timer_Queue'Access;
410
   Timer_Queue.Resume_Time := Duration'Last;
411
   Timer_Server_ID := To_System (Timer_Server'Identity);
412
end System.Tasking.Async_Delays;

powered by: WebSVN 2.1.0

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