gcc/ada/libgnarl/s-tpopmo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --               SYSTEM.TASK_PRIMITIVES.OPERATIONS.MONOTONIC                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2018, 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 --  This is the Monotonic version of this package for Posix and Linux targets.
  33
  34 separate (System.Task_Primitives.Operations)
  35 package body Monotonic is
  36
  37    -----------------------
  38    -- Local Subprograms --
  39    -----------------------
  40
  41    procedure Compute_Deadline
  42      (Time       : Duration;
  43       Mode       : ST.Delay_Modes;
  44       Check_Time : out Duration;
  45       Abs_Time   : out Duration);
  46    --  Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
  47    --  Time and Mode, compute the current clock reading (Check_Time), and the
  48    --  target absolute and relative clock readings (Abs_Time). The
  49    --  epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
  50    --  is always that of CLOCK_RT_Ada.
  51
  52    ---------------------
  53    -- Monotonic_Clock --
  54    ---------------------
  55
  56    function Monotonic_Clock return Duration is
  57       TS     : aliased timespec;
  58       Result : Interfaces.C.int;
  59    begin
  60       Result := clock_gettime
  61         (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
  62       pragma Assert (Result = 0);
  63
  64       return To_Duration (TS);
  65    end Monotonic_Clock;
  66
  67    -------------------
  68    -- RT_Resolution --
  69    -------------------
  70
  71    function RT_Resolution return Duration is
  72       TS     : aliased timespec;
  73       Result : Interfaces.C.int;
  74
  75    begin
  76       Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
  77       pragma Assert (Result = 0);
  78
  79       return To_Duration (TS);
  80    end RT_Resolution;
  81
  82    ----------------------
  83    -- Compute_Deadline --
  84    ----------------------
  85
  86    procedure Compute_Deadline
  87      (Time       : Duration;
  88       Mode       : ST.Delay_Modes;
  89       Check_Time : out Duration;
  90       Abs_Time   : out Duration)
  91    is
  92    begin
  93       Check_Time := Monotonic_Clock;
  94
  95       --  Relative deadline
  96
  97       if Mode = Relative then
  98          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
  99
 100          pragma Warnings (Off);
 101          --  Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
 102          --  time known.
 103
 104       --  Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
 105
 106       elsif Mode = Absolute_RT
 107         or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
 108       then
 109          pragma Warnings (On);
 110          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 111
 112       --  Absolute deadline specified using the calendar clock, in the
 113       --  case where it is not the same as the tasking clock: compensate for
 114       --  difference between clock epochs (Base_Time - Base_Cal_Time).
 115
 116       else
 117          declare
 118             Cal_Check_Time : constant Duration := OS_Primitives.Clock;
 119             RT_Time        : constant Duration :=
 120                                Time + Check_Time - Cal_Check_Time;
 121
 122          begin
 123             Abs_Time :=
 124               Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
 125
 126          end;
 127       end if;
 128    end Compute_Deadline;
 129
 130    -----------------
 131    -- Timed_Sleep --
 132    -----------------
 133
 134    --  This is for use within the run-time system, so abort is
 135    --  assumed to be already deferred, and the caller should be
 136    --  holding its own ATCB lock.
 137
 138    procedure Timed_Sleep
 139      (Self_ID  : ST.Task_Id;
 140       Time     : Duration;
 141       Mode     : ST.Delay_Modes;
 142       Reason   : System.Tasking.Task_States;
 143       Timedout : out Boolean;
 144       Yielded  : out Boolean)
 145    is
 146       pragma Unreferenced (Reason);
 147
 148       Base_Time  : Duration;
 149       Check_Time : Duration;
 150       Abs_Time   : Duration;
 151       P_Abs_Time : Duration;
 152
 153       Request    : aliased timespec;
 154       Result     : Interfaces.C.int;
 155       Exit_Outer : Boolean := False;
 156
 157    begin
 158       Timedout := True;
 159       Yielded := False;
 160
 161       Compute_Deadline
 162         (Time       => Time,
 163          Mode       => Mode,
 164          Check_Time => Check_Time,
 165          Abs_Time   => Abs_Time);
 166       Base_Time := Check_Time;
 167
 168       --  To keep a sensible Max_Sensible_Delay on a target whose system
 169       --  maximum is less than sensible, we split the delay into manageable
 170       --  chunks of time less than or equal to the Max_System_Delay.
 171
 172       if Abs_Time > Check_Time then
 173
 174          Outer : loop
 175
 176             pragma Warnings (Off, "condition is always *");
 177             if Max_System_Delay < Max_Sensible_Delay and then
 178                Abs_Time > Check_Time + Max_System_Delay
 179             then
 180                P_Abs_Time := Check_Time + Max_System_Delay;
 181             else
 182                P_Abs_Time := Abs_Time;
 183                Exit_Outer := True;
 184             end if;
 185             pragma Warnings (On);
 186
 187             Request := To_Timespec (P_Abs_Time);
 188
 189             Inner : loop
 190                exit Outer
 191                   when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 192
 193                Result :=
 194                  pthread_cond_timedwait
 195                    (cond    => Self_ID.Common.LL.CV'Access,
 196                     mutex   => (if Single_Lock
 197                                 then Single_RTS_Lock'Access
 198                                 else Self_ID.Common.LL.L'Access),
 199                     abstime => Request'Access);
 200
 201                case Result is
 202                   when 0 | EINTR =>
 203                      --  Somebody may have called Wakeup for us
 204                      Timedout := False;
 205                      exit Outer;
 206
 207                   when ETIMEDOUT =>
 208                      exit Outer when Exit_Outer;
 209                      Check_Time := Monotonic_Clock;
 210                      exit Inner;
 211
 212                   when others =>
 213                      pragma Assert (False);
 214
 215                end case;
 216
 217                exit Outer
 218                  when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 219
 220             end loop Inner;
 221          end loop Outer;
 222       end if;
 223    end Timed_Sleep;
 224
 225    -----------------
 226    -- Timed_Delay --
 227    -----------------
 228
 229    --  This is for use in implementing delay statements, so we assume the
 230    --  caller is abort-deferred but is holding no locks.
 231
 232    procedure Timed_Delay
 233      (Self_ID : ST.Task_Id;
 234       Time    : Duration;
 235       Mode    : ST.Delay_Modes)
 236    is
 237       Base_Time  : Duration;
 238       Check_Time : Duration;
 239       Abs_Time   : Duration;
 240       P_Abs_Time : Duration;
 241       Request    : aliased timespec;
 242
 243       Result     : Interfaces.C.int;
 244       Exit_Outer : Boolean := False;
 245
 246    begin
 247       if Single_Lock then
 248          Lock_RTS;
 249       end if;
 250
 251       Write_Lock (Self_ID);
 252
 253       Compute_Deadline
 254         (Time       => Time,
 255          Mode       => Mode,
 256          Check_Time => Check_Time,
 257          Abs_Time   => Abs_Time);
 258       Base_Time := Check_Time;
 259
 260       --  To keep a sensible Max_Sensible_Delay on a target whose system
 261       --  maximum is less than sensible, we split the delay into manageable
 262       --  chunks of time less than or equal to the Max_System_Delay.
 263
 264       if Abs_Time > Check_Time then
 265          Self_ID.Common.State := Delay_Sleep;
 266
 267          Outer : loop
 268
 269             pragma Warnings (Off, "condition is always *");
 270             if Max_System_Delay < Max_Sensible_Delay and then
 271               Abs_Time > Check_Time + Max_System_Delay
 272             then
 273                P_Abs_Time := Check_Time + Max_System_Delay;
 274             else
 275                P_Abs_Time := Abs_Time;
 276                Exit_Outer := True;
 277             end if;
 278             pragma Warnings (On);
 279
 280             Request := To_Timespec (P_Abs_Time);
 281
 282             Inner : loop
 283                exit Outer
 284                  when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 285
 286                Result :=
 287                  pthread_cond_timedwait
 288                    (cond    => Self_ID.Common.LL.CV'Access,
 289                     mutex   => (if Single_Lock
 290                                 then Single_RTS_Lock'Access
 291                                 else Self_ID.Common.LL.L'Access),
 292                     abstime => Request'Access);
 293
 294                case Result is
 295                   when ETIMEDOUT =>
 296                      exit Outer when Exit_Outer;
 297                      Check_Time := Monotonic_Clock;
 298                      exit Inner;
 299
 300                   when 0 | EINTR => null;
 301
 302                   when others =>
 303                      pragma Assert (False);
 304
 305                end case;
 306
 307                exit Outer
 308                   when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 309
 310             end loop Inner;
 311          end loop Outer;
 312
 313          Self_ID.Common.State := Runnable;
 314       end if;
 315
 316       Unlock (Self_ID);
 317
 318       if Single_Lock then
 319          Unlock_RTS;
 320       end if;
 321
 322       pragma Unreferenced (Result);
 323       Result := sched_yield;
 324    end Timed_Delay;
 325
 326 end Monotonic;