1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASK_PRIMITIVES.OPERATIONS.MONOTONIC --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the Monotonic version of this package for Posix and Linux targets.
34 separate (System
.Task_Primitives
.Operations
)
35 package body Monotonic
is
37 -----------------------
38 -- Local Subprograms --
39 -----------------------
41 procedure Compute_Deadline
43 Mode
: ST
.Delay_Modes
;
44 Check_Time
: out Duration;
45 Abs_Time
: out Duration;
46 Rel_Time
: out Duration);
47 -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by
48 -- Time and Mode, compute the current clock reading (Check_Time), and the
49 -- target absolute and relative clock readings (Abs_Time, Rel_Time). The
50 -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time
51 -- is always that of CLOCK_RT_Ada.
57 function Monotonic_Clock
return Duration is
58 TS
: aliased timespec
;
59 Result
: Interfaces
.C
.int
;
61 Result
:= clock_gettime
62 (clock_id
=> OSC
.CLOCK_RT_Ada
, tp
=> TS
'Unchecked_Access);
63 pragma Assert
(Result
= 0);
65 return To_Duration
(TS
);
72 function RT_Resolution
return Duration is
73 TS
: aliased timespec
;
74 Result
: Interfaces
.C
.int
;
77 Result
:= clock_getres
(OSC
.CLOCK_REALTIME
, TS
'Unchecked_Access);
78 pragma Assert
(Result
= 0);
80 return To_Duration
(TS
);
83 ----------------------
84 -- Compute_Deadline --
85 ----------------------
87 procedure Compute_Deadline
89 Mode
: ST
.Delay_Modes
;
90 Check_Time
: out Duration;
91 Abs_Time
: out Duration;
92 Rel_Time
: out Duration)
95 Check_Time
:= Monotonic_Clock
;
99 if Mode
= Relative
then
100 Abs_Time
:= Duration'Min (Time
, Max_Sensible_Delay
) + Check_Time
;
102 if Relative_Timed_Wait
then
103 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
);
106 pragma Warnings
(Off
);
107 -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
110 -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
112 elsif Mode
= Absolute_RT
113 or else OSC
.CLOCK_RT_Ada
= OSC
.CLOCK_REALTIME
115 pragma Warnings
(On
);
116 Abs_Time
:= Duration'Min (Check_Time
+ Max_Sensible_Delay
, Time
);
118 if Relative_Timed_Wait
then
119 Rel_Time
:= Duration'Min (Max_Sensible_Delay
, Time
- Check_Time
);
122 -- Absolute deadline specified using the calendar clock, in the
123 -- case where it is not the same as the tasking clock: compensate for
124 -- difference between clock epochs (Base_Time - Base_Cal_Time).
128 Cal_Check_Time
: constant Duration := OS_Primitives
.Clock
;
129 RT_Time
: constant Duration :=
130 Time
+ Check_Time
- Cal_Check_Time
;
134 Duration'Min (Check_Time
+ Max_Sensible_Delay
, RT_Time
);
136 if Relative_Timed_Wait
then
138 Duration'Min (Max_Sensible_Delay
, RT_Time
- Check_Time
);
142 end Compute_Deadline
;
148 -- This is for use within the run-time system, so abort is
149 -- assumed to be already deferred, and the caller should be
150 -- holding its own ATCB lock.
152 procedure Timed_Sleep
153 (Self_ID
: ST
.Task_Id
;
155 Mode
: ST
.Delay_Modes
;
156 Reason
: System
.Tasking
.Task_States
;
157 Timedout
: out Boolean;
158 Yielded
: out Boolean)
160 pragma Unreferenced
(Reason
);
162 Base_Time
: Duration;
163 Check_Time
: Duration;
167 Request
: aliased timespec
;
168 Result
: Interfaces
.C
.int
;
177 Check_Time
=> Check_Time
,
178 Abs_Time
=> Abs_Time
,
179 Rel_Time
=> Rel_Time
);
180 Base_Time
:= Check_Time
;
182 if Abs_Time
> Check_Time
then
184 To_Timespec
(if Relative_Timed_Wait
then Rel_Time
else Abs_Time
);
187 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
190 pthread_cond_timedwait
191 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
192 mutex
=> (if Single_Lock
193 then Single_RTS_Lock
'Access
194 else Self_ID
.Common
.LL
.L
'Access),
195 abstime
=> Request
'Access);
197 Check_Time
:= Monotonic_Clock
;
198 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
200 if Result
in 0 | EINTR
then
202 -- Somebody may have called Wakeup for us
208 pragma Assert
(Result
= ETIMEDOUT
);
217 -- This is for use in implementing delay statements, so we assume the
218 -- caller is abort-deferred but is holding no locks.
220 procedure Timed_Delay
221 (Self_ID
: ST
.Task_Id
;
223 Mode
: ST
.Delay_Modes
)
225 Base_Time
: Duration;
226 Check_Time
: Duration;
229 Request
: aliased timespec
;
231 Result
: Interfaces
.C
.int
;
232 pragma Warnings
(Off
, Result
);
239 Write_Lock
(Self_ID
);
244 Check_Time
=> Check_Time
,
245 Abs_Time
=> Abs_Time
,
246 Rel_Time
=> Rel_Time
);
247 Base_Time
:= Check_Time
;
249 if Abs_Time
> Check_Time
then
251 To_Timespec
(if Relative_Timed_Wait
then Rel_Time
else Abs_Time
);
252 Self_ID
.Common
.State
:= Delay_Sleep
;
255 exit when Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
;
258 pthread_cond_timedwait
259 (cond
=> Self_ID
.Common
.LL
.CV
'Access,
260 mutex
=> (if Single_Lock
261 then Single_RTS_Lock
'Access
262 else Self_ID
.Common
.LL
.L
'Access),
263 abstime
=> Request
'Access);
265 Check_Time
:= Monotonic_Clock
;
266 exit when Abs_Time
<= Check_Time
or else Check_Time
< Base_Time
;
268 pragma Assert
(Result
in 0 | ETIMEDOUT | EINTR
);
271 Self_ID
.Common
.State
:= Runnable
;
280 Result
:= sched_yield
;