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