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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rttiev.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 COMPONENTS                         --
4
--                                                                          --
5
--          A D A . R E A L _ T I M E . T I M I N G _ E V E N T S           --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--           Copyright (C) 2005-2011, Free Software Foundation, Inc.        --
10
--                                                                          --
11
-- GNAT 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
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with System.Task_Primitives.Operations;
33
with System.Tasking.Utilities;
34
with System.Soft_Links;
35
with System.Interrupt_Management.Operations;
36
 
37
with Ada.Containers.Doubly_Linked_Lists;
38
pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
39
 
40
---------------------------------
41
-- Ada.Real_Time.Timing_Events --
42
---------------------------------
43
 
44
package body Ada.Real_Time.Timing_Events is
45
 
46
   use System.Task_Primitives.Operations;
47
 
48
   package SSL renames System.Soft_Links;
49
 
50
   type Any_Timing_Event is access all Timing_Event'Class;
51
   --  We must also handle user-defined types derived from Timing_Event
52
 
53
   ------------
54
   -- Events --
55
   ------------
56
 
57
   package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
58
   --  Provides the type for the container holding pointers to events
59
 
60
   All_Events : Events.List;
61
   --  The queue of pending events, ordered by increasing timeout value, that
62
   --  have been "set" by the user via Set_Handler.
63
 
64
   Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
65
   --  Used for mutually exclusive access to All_Events
66
 
67
   procedure Process_Queued_Events;
68
   --  Examine the queue of pending events for any that have timed out. For
69
   --  those that have timed out, remove them from the queue and invoke their
70
   --  handler (unless the user has cancelled the event by setting the handler
71
   --  pointer to null). Mutually exclusive access is held via Event_Queue_Lock
72
   --  during part of the processing.
73
 
74
   procedure Insert_Into_Queue (This : Any_Timing_Event);
75
   --  Insert the specified event pointer into the queue of pending events
76
   --  with mutually exclusive access via Event_Queue_Lock.
77
 
78
   procedure Remove_From_Queue (This : Any_Timing_Event);
79
   --  Remove the specified event pointer from the queue of pending events with
80
   --  mutually exclusive access via Event_Queue_Lock. This procedure is used
81
   --  by the client-side routines (Set_Handler, etc.).
82
 
83
   -----------
84
   -- Timer --
85
   -----------
86
 
87
   task Timer is
88
      pragma Priority (System.Priority'Last);
89
      entry Start;
90
   end Timer;
91
 
92
   task body Timer is
93
      Period : constant Time_Span := Milliseconds (100);
94
      --  This is a "chiming" clock timer that fires periodically. The period
95
      --  selected is arbitrary and could be changed to suit the application
96
      --  requirements. Obviously a shorter period would give better resolution
97
      --  at the cost of more overhead.
98
 
99
   begin
100
      System.Tasking.Utilities.Make_Independent;
101
 
102
      --  Since this package may be elaborated before System.Interrupt,
103
      --  we need to call Setup_Interrupt_Mask explicitly to ensure that
104
      --  this task has the proper signal mask.
105
 
106
      System.Interrupt_Management.Operations.Setup_Interrupt_Mask;
107
 
108
      --  We await the call to Start to ensure that Event_Queue_Lock has been
109
      --  initialized by the package executable part prior to accessing it in
110
      --  the loop. The task is activated before the first statement of the
111
      --  executable part so it would otherwise be possible for the task to
112
      --  call EnterCriticalSection in Process_Queued_Events before the
113
      --  initialization.
114
 
115
      --  We don't simply put the initialization here, prior to the loop,
116
      --  because other application tasks could call the visible routines that
117
      --  also call Enter/LeaveCriticalSection prior to this task doing the
118
      --  initialization.
119
 
120
      accept Start;
121
 
122
      loop
123
         Process_Queued_Events;
124
         delay until Clock + Period;
125
      end loop;
126
   end Timer;
127
 
128
   ---------------------------
129
   -- Process_Queued_Events --
130
   ---------------------------
131
 
132
   procedure Process_Queued_Events is
133
      Next_Event : Any_Timing_Event;
134
 
135
   begin
136
      loop
137
         SSL.Abort_Defer.all;
138
 
139
         Write_Lock (Event_Queue_Lock'Access);
140
 
141
         if All_Events.Is_Empty then
142
            Unlock (Event_Queue_Lock'Access);
143
            SSL.Abort_Undefer.all;
144
            return;
145
         else
146
            Next_Event := All_Events.First_Element;
147
         end if;
148
 
149
         if Next_Event.Timeout > Clock then
150
 
151
            --  We found one that has not yet timed out. The queue is in
152
            --  ascending order by Timeout so there is no need to continue
153
            --  processing (and indeed we must not continue since we always
154
            --  delete the first element).
155
 
156
            Unlock (Event_Queue_Lock'Access);
157
            SSL.Abort_Undefer.all;
158
            return;
159
         end if;
160
 
161
         --  We have an event that has timed out so we will process it. It must
162
         --  be the first in the queue so no search is needed.
163
 
164
         All_Events.Delete_First;
165
 
166
         --  A fundamental issue is that the invocation of the event's handler
167
         --  might call Set_Handler on itself to re-insert itself back into the
168
         --  queue of future events. Thus we cannot hold the lock on the queue
169
         --  while invoking the event's handler.
170
 
171
         Unlock (Event_Queue_Lock'Access);
172
 
173
         SSL.Abort_Undefer.all;
174
 
175
         --  There is no race condition with the user changing the handler
176
         --  pointer while we are processing because we are executing at the
177
         --  highest possible application task priority and are not doing
178
         --  anything to block prior to invoking their handler.
179
 
180
         declare
181
            Handler : constant Timing_Event_Handler := Next_Event.Handler;
182
 
183
         begin
184
            --  The first act is to clear the event, per D.15(13/2). Besides,
185
            --  we cannot clear the handler pointer *after* invoking the
186
            --  handler because the handler may have re-inserted the event via
187
            --  Set_Event. Thus we take a copy and then clear the component.
188
 
189
            Next_Event.Handler := null;
190
 
191
            if Handler /= null then
192
               Handler.all (Timing_Event (Next_Event.all));
193
            end if;
194
 
195
         --  Ignore exceptions propagated by Handler.all, as required by
196
         --  RM D.15(21/2).
197
 
198
         exception
199
            when others =>
200
               null;
201
         end;
202
      end loop;
203
   end Process_Queued_Events;
204
 
205
   -----------------------
206
   -- Insert_Into_Queue --
207
   -----------------------
208
 
209
   procedure Insert_Into_Queue (This : Any_Timing_Event) is
210
 
211
      function Sooner (Left, Right : Any_Timing_Event) return Boolean;
212
      --  Compares events in terms of timeout values
213
 
214
      package By_Timeout is new Events.Generic_Sorting (Sooner);
215
      --  Used to keep the events in ascending order by timeout value
216
 
217
      ------------
218
      -- Sooner --
219
      ------------
220
 
221
      function Sooner (Left, Right : Any_Timing_Event) return Boolean is
222
      begin
223
         return Left.Timeout < Right.Timeout;
224
      end Sooner;
225
 
226
   --  Start of processing for Insert_Into_Queue
227
 
228
   begin
229
      SSL.Abort_Defer.all;
230
 
231
      Write_Lock (Event_Queue_Lock'Access);
232
 
233
      All_Events.Append (This);
234
 
235
      --  A critical property of the implementation of this package is that
236
      --  all occurrences are in ascending order by Timeout. Thus the first
237
      --  event in the queue always has the "next" value for the Timer task
238
      --  to use in its delay statement.
239
 
240
      By_Timeout.Sort (All_Events);
241
 
242
      Unlock (Event_Queue_Lock'Access);
243
 
244
      SSL.Abort_Undefer.all;
245
   end Insert_Into_Queue;
246
 
247
   -----------------------
248
   -- Remove_From_Queue --
249
   -----------------------
250
 
251
   procedure Remove_From_Queue (This : Any_Timing_Event) is
252
      use Events;
253
      Location : Cursor;
254
 
255
   begin
256
      SSL.Abort_Defer.all;
257
 
258
      Write_Lock (Event_Queue_Lock'Access);
259
 
260
      Location := All_Events.Find (This);
261
 
262
      if Location /= No_Element then
263
         All_Events.Delete (Location);
264
      end if;
265
 
266
      Unlock (Event_Queue_Lock'Access);
267
 
268
      SSL.Abort_Undefer.all;
269
   end Remove_From_Queue;
270
 
271
   -----------------
272
   -- Set_Handler --
273
   -----------------
274
 
275
   procedure Set_Handler
276
     (Event   : in out Timing_Event;
277
      At_Time : Time;
278
      Handler : Timing_Event_Handler)
279
   is
280
   begin
281
      Remove_From_Queue (Event'Unchecked_Access);
282
      Event.Handler := null;
283
 
284
      --  RM D.15(15/2) required that at this point, we check whether the time
285
      --  has already passed, and if so, call Handler.all directly from here
286
      --  instead of doing the enqueuing below. However, this caused a nasty
287
      --  race condition and potential deadlock. If the current task has
288
      --  already locked the protected object of Handler.all, and the time has
289
      --  passed, deadlock would occur. It has been fixed by AI05-0094-1, which
290
      --  says that the handler should be executed as soon as possible, meaning
291
      --  that the timing event will be executed after the protected action
292
      --  finishes (Handler.all should not be called directly from here).
293
      --  The same comment applies to the other Set_Handler below.
294
 
295
      if Handler /= null then
296
         Event.Timeout := At_Time;
297
         Event.Handler := Handler;
298
         Insert_Into_Queue (Event'Unchecked_Access);
299
      end if;
300
   end Set_Handler;
301
 
302
   -----------------
303
   -- Set_Handler --
304
   -----------------
305
 
306
   procedure Set_Handler
307
     (Event   : in out Timing_Event;
308
      In_Time : Time_Span;
309
      Handler : Timing_Event_Handler)
310
   is
311
   begin
312
      Remove_From_Queue (Event'Unchecked_Access);
313
      Event.Handler := null;
314
 
315
      --  See comment in the other Set_Handler above
316
 
317
      if Handler /= null then
318
         Event.Timeout := Clock + In_Time;
319
         Event.Handler := Handler;
320
         Insert_Into_Queue (Event'Unchecked_Access);
321
      end if;
322
   end Set_Handler;
323
 
324
   ---------------------
325
   -- Current_Handler --
326
   ---------------------
327
 
328
   function Current_Handler
329
     (Event : Timing_Event) return Timing_Event_Handler
330
   is
331
   begin
332
      return Event.Handler;
333
   end Current_Handler;
334
 
335
   --------------------
336
   -- Cancel_Handler --
337
   --------------------
338
 
339
   procedure Cancel_Handler
340
     (Event     : in out Timing_Event;
341
      Cancelled : out Boolean)
342
   is
343
   begin
344
      Remove_From_Queue (Event'Unchecked_Access);
345
      Cancelled := Event.Handler /= null;
346
      Event.Handler := null;
347
   end Cancel_Handler;
348
 
349
   -------------------
350
   -- Time_Of_Event --
351
   -------------------
352
 
353
   function Time_Of_Event (Event : Timing_Event) return Time is
354
   begin
355
      --  RM D.15(18/2): Time_First must be returned in the event is not set
356
 
357
      return (if Event.Handler = null then Time_First else Event.Timeout);
358
   end Time_Of_Event;
359
 
360
   --------------
361
   -- Finalize --
362
   --------------
363
 
364
   procedure Finalize (This : in out Timing_Event) is
365
   begin
366
      --  D.15 (19/2) says finalization clears the event
367
 
368
      This.Handler := null;
369
      Remove_From_Queue (This'Unchecked_Access);
370
   end Finalize;
371
 
372
begin
373
   Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
374
   Timer.Start;
375
end Ada.Real_Time.Timing_Events;

powered by: WebSVN 2.1.0

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