Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/s-tpopmo.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 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.
52
53 ---------------------
54 -- Monotonic_Clock --
55 ---------------------
56
57 function Monotonic_Clock return Duration is
58 TS : aliased timespec;
59 Result : Interfaces.C.int;
60 begin
61 Result := clock_gettime
62 (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
63 pragma Assert (Result = 0);
64
65 return To_Duration (TS);
66 end Monotonic_Clock;
67
68 -------------------
69 -- RT_Resolution --
70 -------------------
71
72 function RT_Resolution return Duration is
73 TS : aliased timespec;
74 Result : Interfaces.C.int;
75
76 begin
77 Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
78 pragma Assert (Result = 0);
79
80 return To_Duration (TS);
81 end RT_Resolution;
82
83 ----------------------
84 -- Compute_Deadline --
85 ----------------------
86
87 procedure Compute_Deadline
88 (Time : Duration;
89 Mode : ST.Delay_Modes;
90 Check_Time : out Duration;
91 Abs_Time : out Duration;
92 Rel_Time : out Duration)
93 is
94 begin
95 Check_Time := Monotonic_Clock;
96
97 -- Relative deadline
98
99 if Mode = Relative then
100 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
101
102 if Relative_Timed_Wait then
103 Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
104 end if;
105
106 pragma Warnings (Off);
107 -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile
108 -- time known.
109
110 -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada)
111
112 elsif Mode = Absolute_RT
113 or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME
114 then
115 pragma Warnings (On);
116 Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
117
118 if Relative_Timed_Wait then
119 Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
120 end if;
121
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).
125
126 else
127 declare
128 Cal_Check_Time : constant Duration := OS_Primitives.Clock;
129 RT_Time : constant Duration :=
130 Time + Check_Time - Cal_Check_Time;
131
132 begin
133 Abs_Time :=
134 Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time);
135
136 if Relative_Timed_Wait then
137 Rel_Time :=
138 Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time);
139 end if;
140 end;
141 end if;
142 end Compute_Deadline;
143
144 -----------------
145 -- Timed_Sleep --
146 -----------------
147
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.
151
152 procedure Timed_Sleep
153 (Self_ID : ST.Task_Id;
154 Time : Duration;
155 Mode : ST.Delay_Modes;
156 Reason : System.Tasking.Task_States;
157 Timedout : out Boolean;
158 Yielded : out Boolean)
159 is
160 pragma Unreferenced (Reason);
161
162 Base_Time : Duration;
163 Check_Time : Duration;
164 Abs_Time : Duration;
165 Rel_Time : Duration;
166
167 Request : aliased timespec;
168 Result : Interfaces.C.int;
169
170 begin
171 Timedout := True;
172 Yielded := False;
173
174 Compute_Deadline
175 (Time => Time,
176 Mode => Mode,
177 Check_Time => Check_Time,
178 Abs_Time => Abs_Time,
179 Rel_Time => Rel_Time);
180 Base_Time := Check_Time;
181
182 if Abs_Time > Check_Time then
183 Request :=
184 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
185
186 loop
187 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
188
189 Result :=
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);
196
197 Check_Time := Monotonic_Clock;
198 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
199
200 if Result in 0 | EINTR then
201
202 -- Somebody may have called Wakeup for us
203
204 Timedout := False;
205 exit;
206 end if;
207
208 pragma Assert (Result = ETIMEDOUT);
209 end loop;
210 end if;
211 end Timed_Sleep;
212
213 -----------------
214 -- Timed_Delay --
215 -----------------
216
217 -- This is for use in implementing delay statements, so we assume the
218 -- caller is abort-deferred but is holding no locks.
219
220 procedure Timed_Delay
221 (Self_ID : ST.Task_Id;
222 Time : Duration;
223 Mode : ST.Delay_Modes)
224 is
225 Base_Time : Duration;
226 Check_Time : Duration;
227 Abs_Time : Duration;
228 Rel_Time : Duration;
229 Request : aliased timespec;
230
231 Result : Interfaces.C.int;
232 pragma Warnings (Off, Result);
233
234 begin
235 if Single_Lock then
236 Lock_RTS;
237 end if;
238
239 Write_Lock (Self_ID);
240
241 Compute_Deadline
242 (Time => Time,
243 Mode => Mode,
244 Check_Time => Check_Time,
245 Abs_Time => Abs_Time,
246 Rel_Time => Rel_Time);
247 Base_Time := Check_Time;
248
249 if Abs_Time > Check_Time then
250 Request :=
251 To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time);
252 Self_ID.Common.State := Delay_Sleep;
253
254 loop
255 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
256
257 Result :=
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);
264
265 Check_Time := Monotonic_Clock;
266 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
267
268 pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
269 end loop;
270
271 Self_ID.Common.State := Runnable;
272 end if;
273
274 Unlock (Self_ID);
275
276 if Single_Lock then
277 Unlock_RTS;
278 end if;
279
280 Result := sched_yield;
281 end Timed_Delay;
282
283 end Monotonic;