gcc/ada/a-rttiev.adb

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