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