File : s-osprim-mingw.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . O S _ P R I M I T I V E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2015, 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 -- --
19 -- --
20 -- --
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 NT version of this package
33
34 with System.Task_Lock;
35 with System.Win32.Ext;
36
37 package body System.OS_Primitives is
38
39 use System.Task_Lock;
40 use System.Win32;
41 use System.Win32.Ext;
42
43 ----------------------------------------
44 -- Data for the high resolution clock --
45 ----------------------------------------
46
47 Tick_Frequency : aliased LARGE_INTEGER;
48 -- Holds frequency of high-performance counter used by Clock
49 -- Windows NT uses a 1_193_182 Hz counter on PCs.
50
51 Base_Monotonic_Ticks : LARGE_INTEGER;
52 -- Holds the Tick count for the base monotonic time
53
54 Base_Monotonic_Clock : Duration;
55 -- Holds the current clock for monotonic clock's base time
56
57 type Clock_Data is record
58 Base_Ticks : LARGE_INTEGER;
59 -- Holds the Tick count for the base time
60
61 Base_Time : Long_Long_Integer;
62 -- Holds the base time used to check for system time change, used with
63 -- the standard clock.
64
65 Base_Clock : Duration;
66 -- Holds the current clock for the standard clock's base time
67 end record;
68
69 type Clock_Data_Access is access all Clock_Data;
70
71 -- Two base clock buffers. This is used to be able to update a buffer while
72 -- the other buffer is read. The point is that we do not want to use a lock
73 -- inside the Clock routine for performance reasons. We still use a lock
74 -- in the Get_Base_Time which is called very rarely. Current is a pointer,
75 -- the pragma Atomic is there to ensure that the value can be set or read
76 -- atomically. That's it, when Get_Base_Time has updated a buffer the
77 -- switch to the new value is done by changing Current pointer.
78
79 First, Second : aliased Clock_Data;
80
81 Current : Clock_Data_Access := First'Access;
82 pragma Atomic (Current);
83
84 -- The following signature is to detect change on the base clock data
85 -- above. The signature is a modular type, it will wrap around without
86 -- raising an exception. We would need to have exactly 2**32 updates of
87 -- the base data for the changes to get undetected.
88
89 type Signature_Type is mod 2**32;
90 Signature : Signature_Type := 0;
91 pragma Atomic (Signature);
92
93 function Monotonic_Clock return Duration;
94 pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock");
95 -- Return "absolute" time, represented as an offset relative to "the Unix
96 -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is
97 -- immune to the system's clock changes. Export this function so that it
98 -- can be imported from s-taprop-mingw.adb without changing the shared
99 -- spec (s-osprim.ads).
100
101 procedure Get_Base_Time (Data : in out Clock_Data);
102 -- Retrieve the base time and base ticks. These values will be used by
103 -- clock to compute the current time by adding to it a fraction of the
104 -- performance counter. This is for the implementation of a high-resolution
105 -- clock. Note that this routine does not change the base monotonic values
106 -- used by the monotonic clock.
107
108 -----------
109 -- Clock --
110 -----------
111
112 -- This implementation of clock provides high resolution timer values
113 -- using QueryPerformanceCounter. This call return a 64 bits values (based
114 -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182
115 -- times per seconds. The call to QueryPerformanceCounter takes 6
116 -- microsecs to complete.
117
118 function Clock return Duration is
119 Max_Shift : constant Duration := 2.0;
120 Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
121 Data : Clock_Data;
122 Current_Ticks : aliased LARGE_INTEGER;
123 Elap_Secs_Tick : Duration;
124 Elap_Secs_Sys : Duration;
125 Now : aliased Long_Long_Integer;
126 Sig1, Sig2 : Signature_Type;
127
128 begin
129 -- Try ten times to get a coherent set of base data. For this we just
130 -- check that the signature hasn't changed during the copy of the
131 -- current data.
132 --
133 -- This loop will always be done once if there is no interleaved call
134 -- to Get_Base_Time.
135
136 for K in 1 .. 10 loop
137 Sig1 := Signature;
138 Data := Current.all;
139 Sig2 := Signature;
140 exit when Sig1 = Sig2;
141 end loop;
142
143 if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
144 return 0.0;
145 end if;
146
147 GetSystemTimeAsFileTime (Now'Access);
148
149 Elap_Secs_Sys :=
150 Duration (Long_Long_Float (abs (Now - Data.Base_Time)) /
151 Hundreds_Nano_In_Sec);
152
153 Elap_Secs_Tick :=
154 Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
155 Long_Long_Float (Tick_Frequency));
156
157 -- If we have a shift of more than Max_Shift seconds we resynchronize
158 -- the Clock. This is probably due to a manual Clock adjustment, a DST
159 -- adjustment or an NTP synchronisation. And we want to adjust the time
160 -- for this system (non-monotonic) clock.
161
162 if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
163 Get_Base_Time (Data);
164
165 Elap_Secs_Tick :=
166 Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
167 Long_Long_Float (Tick_Frequency));
168 end if;
169
170 return Data.Base_Clock + Elap_Secs_Tick;
171 end Clock;
172
173 -------------------
174 -- Get_Base_Time --
175 -------------------
176
177 procedure Get_Base_Time (Data : in out Clock_Data) is
178
179 -- The resolution for GetSystemTime is 1 millisecond
180
181 -- The time to get both base times should take less than 1 millisecond.
182 -- Therefore, the elapsed time reported by GetSystemTime between both
183 -- actions should be null.
184
185 epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
186 system_time_ns : constant := 100; -- 100 ns per tick
187 Sec_Unit : constant := 10#1#E9;
188
189 Max_Elapsed : constant LARGE_INTEGER :=
190 LARGE_INTEGER (Tick_Frequency / 100_000);
191 -- Look for a precision of 0.01 ms
192
193 Sig : constant Signature_Type := Signature;
194
195 Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER;
196 Loc_Time, Ctrl_Time : aliased Long_Long_Integer;
197 Elapsed : LARGE_INTEGER;
198 Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last;
199 New_Data : Clock_Data_Access;
200
201 begin
202 -- Here we must be sure that both of these calls are done in a short
203 -- amount of time. Both are base time and should in theory be taken
204 -- at the very same time.
205
206 -- The goal of the following loop is to synchronize the system time
207 -- with the Win32 performance counter by getting a base offset for both.
208 -- Using these offsets it is then possible to compute actual time using
209 -- a performance counter which has a better precision than the Win32
210 -- time API.
211
212 -- Try at most 10 times to reach the best synchronisation (below 1
213 -- millisecond) otherwise the runtime will use the best value reached
214 -- during the runs.
215
216 Lock;
217
218 -- First check that the current value has not been updated. This
219 -- could happen if another task has called Clock at the same time
220 -- and that Max_Shift has been reached too.
221 --
222 -- But if the current value has been changed just before we entered
223 -- into the critical section, we can safely return as the current
224 -- base data (time, clock, ticks) have already been updated.
225
226 if Sig /= Signature then
227 Unlock;
228 return;
229 end if;
230
231 -- Check for the unused data buffer and set New_Data to point to it
232
233 if Current = First'Access then
234 New_Data := Second'Access;
235 else
236 New_Data := First'Access;
237 end if;
238
239 for K in 1 .. 10 loop
240 if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then
241 pragma Assert
242 (Standard.False,
243 "Could not query high performance counter in Clock");
244 null;
245 end if;
246
247 GetSystemTimeAsFileTime (Ctrl_Time'Access);
248
249 -- Scan for clock tick, will take up to 16ms/1ms depending on PC.
250 -- This cannot be an infinite loop or the system hardware is badly
251 -- damaged.
252
253 loop
254 GetSystemTimeAsFileTime (Loc_Time'Access);
255
256 if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then
257 pragma Assert
258 (Standard.False,
259 "Could not query high performance counter in Clock");
260 null;
261 end if;
262
263 exit when Loc_Time /= Ctrl_Time;
264 Loc_Ticks := Ctrl_Ticks;
265 end loop;
266
267 -- Check elapsed Performance Counter between samples
268 -- to choose the best one.
269
270 Elapsed := Ctrl_Ticks - Loc_Ticks;
271
272 if Elapsed < Current_Max then
273 New_Data.Base_Time := Loc_Time;
274 New_Data.Base_Ticks := Loc_Ticks;
275 Current_Max := Elapsed;
276
277 -- Exit the loop when we have reached the expected precision
278
279 exit when Elapsed <= Max_Elapsed;
280 end if;
281 end loop;
282
283 New_Data.Base_Clock :=
284 Duration
285 (Long_Long_Float
286 ((New_Data.Base_Time - epoch_1970) * system_time_ns) /
287 Long_Long_Float (Sec_Unit));
288
289 -- At this point all the base values have been set into the new data
290 -- record. Change the pointer (atomic operation) to these new values.
291
292 Current := New_Data;
293 Data := New_Data.all;
294
295 -- Set new signature for this data set
296
297 Signature := Signature + 1;
298
299 Unlock;
300
301 exception
302 when others =>
303 Unlock;
304 raise;
305 end Get_Base_Time;
306
307 ---------------------
308 -- Monotonic_Clock --
309 ---------------------
310
311 function Monotonic_Clock return Duration is
312 Current_Ticks : aliased LARGE_INTEGER;
313 Elap_Secs_Tick : Duration;
314
315 begin
316 if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
317 return 0.0;
318
319 else
320 Elap_Secs_Tick :=
321 Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) /
322 Long_Long_Float (Tick_Frequency));
323 return Base_Monotonic_Clock + Elap_Secs_Tick;
324 end if;
325 end Monotonic_Clock;
326
327 -----------------
328 -- Timed_Delay --
329 -----------------
330
331 procedure Timed_Delay (Time : Duration; Mode : Integer) is
332
333 function Mode_Clock return Duration;
334 pragma Inline (Mode_Clock);
335 -- Return the current clock value using either the monotonic clock or
336 -- standard clock depending on the Mode value.
337
338 ----------------
339 -- Mode_Clock --
340 ----------------
341
342 function Mode_Clock return Duration is
343 begin
344 case Mode is
345 when Absolute_RT =>
346 return Monotonic_Clock;
347 when others =>
348 return Clock;
349 end case;
350 end Mode_Clock;
351
352 -- Local Variables
353
354 Base_Time : constant Duration := Mode_Clock;
355 -- Base_Time is used to detect clock set backward, in this case we
356 -- cannot ensure the delay accuracy.
357
358 Rel_Time : Duration;
359 Abs_Time : Duration;
360 Check_Time : Duration := Base_Time;
361
362 -- Start of processing for Timed Delay
363
364 begin
365 if Mode = Relative then
366 Rel_Time := Time;
367 Abs_Time := Time + Check_Time;
368 else
369 Rel_Time := Time - Check_Time;
370 Abs_Time := Time;
371 end if;
372
373 if Rel_Time > 0.0 then
374 loop
375 Sleep (DWORD (Rel_Time * 1000.0));
376 Check_Time := Mode_Clock;
377
378 exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
379
380 Rel_Time := Abs_Time - Check_Time;
381 end loop;
382 end if;
383 end Timed_Delay;
384
385 ----------------
386 -- Initialize --
387 ----------------
388
389 Initialized : Boolean := False;
390
391 procedure Initialize is
392 begin
393 if Initialized then
394 return;
395 end if;
396
397 Initialized := True;
398
399 -- Get starting time as base
400
401 if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then
402 raise Program_Error with
403 "cannot get high performance counter frequency";
404 end if;
405
406 Get_Base_Time (Current.all);
407
408 -- Keep base clock and ticks for the monotonic clock. These values
409 -- should never be changed to ensure proper behavior of the monotonic
410 -- clock.
411
412 Base_Monotonic_Clock := Current.Base_Clock;
413 Base_Monotonic_Ticks := Current.Base_Ticks;
414 end Initialize;
415
416 end System.OS_Primitives;