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-2020, 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   => Self_ID.Common.LL.L'Access,
197                    abstime => Request'Access);
198
199               case Result is
200                  when 0 | EINTR =>
201                     --  Somebody may have called Wakeup for us
202                     Timedout := False;
203                     exit Outer;
204
205                  when ETIMEDOUT =>
206                     exit Outer when Exit_Outer;
207                     Check_Time := Monotonic_Clock;
208                     exit Inner;
209
210                  when others =>
211                     pragma Assert (False);
212
213               end case;
214
215               exit Outer
216                 when Abs_Time <= Check_Time or else Check_Time < Base_Time;
217
218            end loop Inner;
219         end loop Outer;
220      end if;
221   end Timed_Sleep;
222
223   -----------------
224   -- Timed_Delay --
225   -----------------
226
227   --  This is for use in implementing delay statements, so we assume the
228   --  caller is abort-deferred but is holding no locks.
229
230   procedure Timed_Delay
231     (Self_ID : ST.Task_Id;
232      Time    : Duration;
233      Mode    : ST.Delay_Modes)
234   is
235      Base_Time  : Duration;
236      Check_Time : Duration;
237      Abs_Time   : Duration;
238      P_Abs_Time : Duration;
239      Request    : aliased timespec;
240
241      Result     : Interfaces.C.int;
242      Exit_Outer : Boolean := False;
243
244   begin
245      Write_Lock (Self_ID);
246
247      Compute_Deadline
248        (Time       => Time,
249         Mode       => Mode,
250         Check_Time => Check_Time,
251         Abs_Time   => Abs_Time);
252      Base_Time := Check_Time;
253
254      --  To keep a sensible Max_Sensible_Delay on a target whose system
255      --  maximum is less than sensible, we split the delay into manageable
256      --  chunks of time less than or equal to the Max_System_Delay.
257
258      if Abs_Time > Check_Time then
259         Self_ID.Common.State := Delay_Sleep;
260
261         Outer : loop
262
263            pragma Warnings (Off, "condition is always *");
264            if Max_System_Delay < Max_Sensible_Delay and then
265              Abs_Time > Check_Time + Max_System_Delay
266            then
267               P_Abs_Time := Check_Time + Max_System_Delay;
268            else
269               P_Abs_Time := Abs_Time;
270               Exit_Outer := True;
271            end if;
272            pragma Warnings (On);
273
274            Request := To_Timespec (P_Abs_Time);
275
276            Inner : loop
277               exit Outer
278                 when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
279
280               Result :=
281                 pthread_cond_timedwait
282                   (cond    => Self_ID.Common.LL.CV'Access,
283                    mutex   => Self_ID.Common.LL.L'Access,
284                    abstime => Request'Access);
285
286               case Result is
287                  when ETIMEDOUT =>
288                     exit Outer when Exit_Outer;
289                     Check_Time := Monotonic_Clock;
290                     exit Inner;
291
292                  when 0 | EINTR => null;
293
294                  when others =>
295                     pragma Assert (False);
296
297               end case;
298
299               exit Outer
300                  when Abs_Time <= Check_Time or else Check_Time < Base_Time;
301
302            end loop Inner;
303         end loop Outer;
304
305         Self_ID.Common.State := Runnable;
306      end if;
307
308      Unlock (Self_ID);
309      pragma Unreferenced (Result);
310      Result := sched_yield;
311   end Timed_Delay;
312
313end Monotonic;
314