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-2019, 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
34separate (System.Task_Primitives.Operations)
35package 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
326end Monotonic;
327