File : a-reatim-xi.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- A D A . R E A L _ T I M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2016, AdaCore --
10 -- --
11 -- GNAT 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 Ravenscar version of this package for generic bare board
33 -- targets. Note that the operations here assume that Time is a 64-bit
34 -- unsigned integer and Time_Span is a 64-bit signed integer.
35
36 with System.Tasking;
37 with System.Task_Primitives.Operations;
38
39 with Ada.Unchecked_Conversion;
40
41 package body Ada.Real_Time with
42 SPARK_Mode => Off
43 is
44 pragma Suppress (Overflow_Check);
45 -- This package has careful manual overflow checks, and unsuppresses them
46 -- where appropriate. This default enables compilation with checks enabled
47 -- on Ravenscar SFP, where 64-bit multiplication with overflow checking is
48 -- not available.
49
50 package OSI renames System.OS_Interface;
51 subtype LLI is Long_Long_Integer;
52
53 ------------------------------------------------------------
54 -- Handling of Conversions Between Duration and Time_Span --
55 ------------------------------------------------------------
56
57 -- For the To_Duration and To_Time_Span conversion functions, we use the
58 -- intermediate Integer representation of Duration (64-bit) to allow for
59 -- simple Integer operations instead of Float. We take advantage of the
60 -- fact that Duration is represented as an Integer with units of Small.
61 -- Within these conversions we perform the range checks required by
62 -- AI-00432 manually.
63
64 -- Note that in the past, within To_Duration and To_Time_Span, we were
65 -- first computing the conversion factor between Duration and Time_Span
66 -- (10 ** 9 / Clock_Frecuency) and then we multiplied or divided by it. The
67 -- advantage of this approach was that the operations were simple, and we
68 -- limited a lot the number of occurrences of overflows, but the accuracy
69 -- loss could be significant depending on the clock frequency. For example,
70 -- with a clock frequency of 600 MHz the factor was 1.66, which was rounded
71 -- to 1 (Integer), and hence with a 67% difference.
72
73 -- We tried also to have a better tradeoff (Constraint_Error being raised
74 -- when transforming very big values, but limiting a lot the loss of
75 -- accuracy) using Clock_Frequency in MHz instead of Hz. Therefore, we
76 -- multiplied first by 10 ** 3 (or Clock_Frequency / 10 ** 6 which is
77 -- typically smaller than 1000), and hence overflow could occur only with
78 -- really big values). The problem of this approach was that some processor
79 -- frequencies may not be expressed in multiples of MHz (for example,
80 -- 33.3333 MHz). The approach finally followed is to do the operations
81 -- "by hand" on the upper and the lower part of the 64-bit value. This is
82 -- slightly heavier, but we can preserve the best accuracy and the lowest
83 -- occurrence of overflows.
84
85 pragma Compile_Time_Error
86 (Duration'Size /= 64,
87 "this version of Ada.Real_Time requires 64-bit Duration");
88
89 -----------------------
90 -- Local definitions --
91 -----------------------
92
93 type Uint_64 is mod 2 ** 64;
94 -- Type used to represent intermediate results of arithmetic operations
95
96 Max_Pos_Time_Span : constant := Uint_64 (Time_Span_Last);
97 Max_Neg_Time_Span : constant := Uint_64 (2 ** 63);
98 -- Absolute value of Time_Span_Last and Time_Span_First. Used in overflow
99 -- checks. Note that we avoid using abs on Time_Span_First everywhere.
100
101 -----------------------
102 -- Local subprograms --
103 -----------------------
104
105 function Mul_Div (V : LLI; M : Natural; D : Positive) return LLI;
106 -- Compute V * M / D where division rounds to the nearest integer, away
107 -- from zero if exactly halfway between. If the result would overflow then
108 -- Constraint_Error is raised.
109
110 function Rounded_Div (L, R : LLI) return LLI;
111 pragma Inline (Rounded_Div);
112 -- Return L / R rounded to the nearest integer, away from zero if exactly
113 -- halfway between; required to implement ARM D.8 (26). Assumes R > 0.
114
115 function To_Duration is
116 new Ada.Unchecked_Conversion (LLI, Duration);
117
118 function To_Integer is
119 new Ada.Unchecked_Conversion (Duration, LLI);
120
121 function To_Integer is
122 new Ada.Unchecked_Conversion (Time_Span, LLI);
123
124 ---------------------
125 -- Local constants --
126 ---------------------
127
128 Duration_Units : constant Positive := Positive (1.0 / Duration'Small);
129 -- Number of units of Duration in one second. The result is correct (not
130 -- rounded) as Duration'Small is 10.0**(-9).
131
132 ---------
133 -- "*" --
134 ---------
135
136 function "*" (Left : Time_Span; Right : Integer) return Time_Span is
137 Is_Negative : constant Boolean :=
138 (if Left > 0 then
139 Right < 0
140 elsif Left < 0
141 then Right > 0
142 else
143 False);
144 -- Sign of the result
145
146 Max_Value : constant Uint_64 :=
147 (if Is_Negative then
148 Max_Neg_Time_Span
149 else
150 Max_Pos_Time_Span);
151 -- Maximum absolute value that can be returned by the multiplication
152 -- taking into account the sign of the operators.
153
154 Abs_Left : constant Uint_64 :=
155 (if Left = Time_Span_First then
156 Max_Neg_Time_Span
157 else
158 Uint_64 (abs (Left)));
159 -- Remove sign of left operator
160
161 Abs_Right : constant Uint_64 := Uint_64 (abs (LLI (Right)));
162 -- Remove sign of right operator
163
164 begin
165 -- Overflow check is performed by hand assuming that Time_Span is a
166 -- 64-bit signed integer. Otherwise these checks would need an
167 -- intermediate type with more than 64-bit. The sign of the operators
168 -- is removed to simplify the intermediate computation of the overflow
169 -- check.
170
171 if Abs_Right /= 0 and then Max_Value / Abs_Right < Abs_Left then
172 raise Constraint_Error;
173 else
174 return Left * Time_Span (Right);
175 end if;
176 end "*";
177
178 function "*" (Left : Integer; Right : Time_Span) return Time_Span is
179 begin
180 return Right * Left;
181 end "*";
182
183 ---------
184 -- "+" --
185 ---------
186
187 function "+" (Left : Time; Right : Time_Span) return Time is
188 begin
189 -- Overflow checks are performed by hand assuming that Time and
190 -- Time_Span are 64-bit unsigned and signed integers respectively.
191 -- Otherwise these checks would need an intermediate type with more
192 -- than 64 bits.
193
194 if Right >= 0
195 and then Uint_64 (Time_Last) - Uint_64 (Left) >= Uint_64 (Right)
196 then
197 return Time (Uint_64 (Left) + Uint_64 (Right));
198
199 -- The case of Right = Time_Span'First needs to be treated differently
200 -- because the absolute value of -2 ** 63 is not within the range of
201 -- Time_Span.
202
203 elsif Right = Time_Span'First and then Left >= Max_Neg_Time_Span then
204 return Time (Uint_64 (Left) - Max_Neg_Time_Span);
205
206 elsif Right < 0 and then Right > Time_Span'First
207 and then Left >= Time (abs (Right))
208 then
209 return Time (Uint_64 (Left) - Uint_64 (abs (Right)));
210
211 else
212 raise Constraint_Error;
213 end if;
214 end "+";
215
216 function "+" (Left, Right : Time_Span) return Time_Span is
217 pragma Unsuppress (Overflow_Check);
218 begin
219 return Time_Span (LLI (Left) + LLI (Right));
220 end "+";
221
222 ---------
223 -- "-" --
224 ---------
225
226 function "-" (Left : Time; Right : Time_Span) return Time is
227 begin
228 -- Overflow checks must be performed by hand assuming that Time and
229 -- Time_Span are 64-bit unsigned and signed integers respectively.
230 -- Otherwise these checks would need an intermediate type with more
231 -- than 64-bit.
232
233 if Right >= 0 and then Left >= Time (Right) then
234 return Time (Uint_64 (Left) - Uint_64 (Right));
235
236 -- The case of Right = Time_Span'First needs to be treated differently
237 -- because the absolute value of -2 ** 63 is not within the range of
238 -- Time_Span.
239
240 elsif Right = Time_Span'First
241 and then Uint_64 (Time_Last) - Uint_64 (Left) >= Max_Neg_Time_Span
242 then
243 return Left + Time (Max_Neg_Time_Span);
244
245 elsif Right < 0 and then Right > Time_Span'First
246 and then Uint_64 (Time_Last) - Uint_64 (Left) >= Uint_64 (abs (Right))
247 then
248 return Left + Time (abs (Right));
249
250 else
251 raise Constraint_Error;
252 end if;
253 end "-";
254
255 function "-" (Left, Right : Time) return Time_Span is
256 begin
257 -- Overflow checks must be performed by hand assuming that Time and
258 -- Time_Span are 64-bit unsigned and signed integers respectively.
259 -- Otherwise these checks would need an intermediate type with more
260 -- than 64-bit.
261
262 if Left >= Right
263 and then Uint_64 (Left) - Uint_64 (Right) <= Max_Pos_Time_Span
264 then
265 return Time_Span (Uint_64 (Left) - Uint_64 (Right));
266
267 elsif Left < Right
268 and then Uint_64 (Right) - Uint_64 (Left) <= Max_Neg_Time_Span
269 then
270 return -1 - Time_Span (Uint_64 (Right) - Uint_64 (Left) - 1);
271
272 else
273 raise Constraint_Error;
274 end if;
275 end "-";
276
277 function "-" (Left, Right : Time_Span) return Time_Span is
278 pragma Unsuppress (Overflow_Check);
279 begin
280 return Time_Span (LLI (Left) - LLI (Right));
281 end "-";
282
283 function "-" (Right : Time_Span) return Time_Span is
284 pragma Unsuppress (Overflow_Check);
285 begin
286 return Time_Span (-LLI (Right));
287 end "-";
288
289 ---------
290 -- "/" --
291 ---------
292
293 function "/" (Left, Right : Time_Span) return Integer is
294 pragma Unsuppress (Overflow_Check);
295 pragma Unsuppress (Division_Check);
296 begin
297 return Integer (LLI (Left) / LLI (Right));
298 end "/";
299
300 function "/" (Left : Time_Span; Right : Integer) return Time_Span is
301 pragma Unsuppress (Overflow_Check);
302 pragma Unsuppress (Division_Check);
303 begin
304 return Left / Time_Span (Right);
305 end "/";
306
307 -----------
308 -- Clock --
309 -----------
310
311 function Clock return Time is
312 begin
313 return Time (System.Task_Primitives.Operations.Monotonic_Clock);
314 end Clock;
315
316 ------------------
317 -- Microseconds --
318 ------------------
319
320 function Microseconds (US : Integer) return Time_Span is
321 begin
322 -- Overflow can't happen (Ticks_Per_Second is Natural)
323
324 return
325 Time_Span (Rounded_Div (LLI (US) * LLI (OSI.Ticks_Per_Second), 1E6));
326 end Microseconds;
327
328 ------------------
329 -- Milliseconds --
330 ------------------
331
332 function Milliseconds (MS : Integer) return Time_Span is
333 begin
334 -- Overflow can't happen (Ticks_Per_Second is Natural)
335
336 return
337 Time_Span (Rounded_Div (LLI (MS) * LLI (OSI.Ticks_Per_Second), 1E3));
338 end Milliseconds;
339
340 -------------
341 -- Minutes --
342 -------------
343
344 function Minutes (M : Integer) return Time_Span is
345 Min_M : constant LLI := LLI'First / LLI (OSI.Ticks_Per_Second);
346 Max_M : constant LLI := LLI'Last / LLI (OSI.Ticks_Per_Second);
347 -- Bounds for Sec_M. Note that we can't use unsuppress overflow checks,
348 -- as this would require the use of arit64.
349
350 Sec_M : constant LLI := LLI (M) * 60;
351 -- M converted to seconds
352
353 begin
354 if Sec_M < Min_M or else Sec_M > Max_M then
355 raise Constraint_Error;
356 else
357 return Time_Span (Sec_M * LLI (OSI.Ticks_Per_Second));
358 end if;
359 end Minutes;
360
361 -------------
362 -- Mul_Div --
363 -------------
364
365 function Mul_Div (V : LLI; M : Natural; D : Positive) return LLI is
366
367 -- We first multiply V * M and then divide the result by D, while
368 -- avoiding overflow in intermediate calculations and detecting it in
369 -- the final result. To get the rounding to the nearest integer, away
370 -- from zero if exactly halfway between two values, we add +/- D/2
371 -- (depending on the sign on V) directly at the end of multiplication.
372 --
373 -- ----------------------------------------
374 -- Multiplication (and rounding adjustment)
375 -- ----------------------------------------
376 --
377 -- Since V is a signed 64-bit integer and M is signed (but non-negative)
378 -- 32-bit integer, their product may not fit in 64-bits. To avoid
379 -- overflow we split V and into high and low parts
380 --
381 -- V_Hi = V / 2 ** 32
382 -- V_Lo = V rem 2 ** 32
383 --
384 -- where each part is either zero or has the sign of the dividend; thus
385 --
386 -- V = V_Hi * 2 ** 32 + V_Lo
387 --
388 -- In either case V_Hi and V_Lo are in range of 32-bit signed integer,
389 -- yet stored in 64-bit signed variables. When multiplied by M, which is
390 -- in range of 0 .. 2 ** 31 - 1, the results will still fit in 64-bit
391 -- integer, even if we extend it by D/2 as required to implement
392 -- rounding. We will get the value of V * M ± D/2 as low and high part:
393 --
394 -- (V * M ± D/2)_Lo = (V_Lo * M ± D/2) with carry zeroed
395 -- (V * M ± D/2)_Hi = (V_Hi * M) with carry from (V_Lo * M ± D/2)
396 --
397 -- (carry flows only from low to high part), or mathematically speaking:
398 --
399 -- (V * M ± D/2)_Lo = (V * M ± D/2) rem 2 ** 32
400 -- (V * M ± D/2)_Hi = (V * M ± D/2) / 2 ** 32
401 --
402 -- and thus
403 --
404 -- V * M ± D/2 = (V * M ± D/2)_Hi * 2 ** 32 + (V * M ± D/2)_Lo
405 --
406 -- with signs just like described for V_Hi and V_Lo.
407 --
408 -- --------
409 -- Division
410 -- --------
411 --
412 -- The final result (V * M ± D/2) / D is computed as a high and low
413 -- parts:
414 --
415 -- ((V * M ± D/2) / D)_Hi = (V * M ± D/2)_Hi / D
416 -- ((V * M ± D/2) / D)_Lo =
417 -- ((V * M ± D/2)_Lo + remainder from high part division) / D
418 --
419 -- (remainder flows only from high to low part, opposite to carry),
420 -- or mathematically speaking:
421 --
422 -- ((V * M ± D/2) / D)_Hi = ((V * M ± D/2) / D) / 2 ** 32
423 -- ((V * M ± D/2) / D)_Lo = ((V * M ± D/2) / D) rem 2 ** 32
424 --
425 -- and thus
426 --
427 -- (V * M ± D/2) / D = ((V * M ± D/2) / D)_Hi * 2 ** 32
428 -- + ((V * M ± D/2) / D)_Lo
429 --
430 -- with signs just like described for V_Hi and V_Lo.
431 --
432 -- References: this calculation is partly inspired by Knuth's algorithm
433 -- in TAoCP Vol.2, section 4.3.1, excercise 16. However, here it is
434 -- adapted it for signed arithmetic; has no loop (since the input number
435 -- has fixed width); and discard the remainder of the result.
436
437 V_Hi : constant LLI := V / 2 ** 32;
438 V_Lo : constant LLI := V rem 2 ** 32;
439 -- High and low parts of V
440
441 V_M_Hi : LLI;
442 V_M_Lo : LLI;
443 -- High and low parts of V * M (+-) D / 2
444
445 Result_Hi : LLI;
446 -- High part of the result
447
448 Result_Lo : LLI;
449 -- Low part of the result
450
451 Remainder : LLI;
452 -- Remainder of the first division
453
454 begin
455 -- Multiply V * M and add/subtract D/2
456
457 V_M_Lo := V_Lo * LLI (M) + (if V >= 0 then 1 else -1) * LLI (D / 2);
458 V_M_Hi := V_Hi * LLI (M) + V_M_Lo / 2 ** 32;
459 V_M_Lo := V_M_Lo rem 2 ** 32;
460
461 -- First quotient
462
463 Result_Hi := V_M_Hi / LLI (D);
464
465 -- The final result would overflow
466
467 if Result_Hi not in -(2 ** 31) .. 2 ** 31 - 1 then
468 raise Constraint_Error;
469 end if;
470
471 Remainder := V_M_Hi rem LLI (D);
472 Result_Hi := Result_Hi * 2 ** 32;
473
474 -- Second quotient
475
476 Result_Lo := (V_M_Lo + Remainder * 2 ** 32) / LLI (D);
477
478 -- Combine low and high parts of the result
479
480 return Result_Hi + Result_Lo;
481 end Mul_Div;
482
483 -----------------
484 -- Nanoseconds --
485 -----------------
486
487 function Nanoseconds (NS : Integer) return Time_Span is
488 begin
489 -- Overflow can't happen (Ticks_Per_Second is Natural)
490
491 return
492 Time_Span (Rounded_Div (LLI (NS) * LLI (OSI.Ticks_Per_Second), 1E9));
493 end Nanoseconds;
494
495 -----------------
496 -- Rounded_Div --
497 -----------------
498
499 function Rounded_Div (L, R : LLI) return LLI is
500 Left : LLI;
501 begin
502 if L >= 0 then
503 Left := L + R / 2;
504 else
505 Left := L - R / 2;
506 end if;
507
508 return Left / R;
509 end Rounded_Div;
510
511 -------------
512 -- Seconds --
513 -------------
514
515 function Seconds (S : Integer) return Time_Span is
516 begin
517 -- Overflow can't happen (Ticks_Per_Second is Natural)
518
519 return Time_Span (LLI (S) * LLI (OSI.Ticks_Per_Second));
520 end Seconds;
521
522 -----------
523 -- Split --
524 -----------
525
526 procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
527 Res : constant Time := Time (OSI.Ticks_Per_Second);
528 begin
529 SC := Seconds_Count (T / Res);
530 TS := T - Time (SC) * Res;
531 end Split;
532
533 -------------
534 -- Time_Of --
535 -------------
536
537 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
538 Res : constant Time := Time (OSI.Ticks_Per_Second);
539
540 begin
541 -- We want to return SC * Resolution + TS. To avoid spurious overflows
542 -- in the intermediate result (SC * Resolution) we take advantage of the
543 -- different signs in SC and TS (when that is the case).
544
545 -- If signs of SC and TS are different then we avoid converting SC to
546 -- Time (as we do in the else part). The reason for that is that SC
547 -- converted to Time may overflow the range of Time, while the addition
548 -- of SC plus TS does not overflow (because of their different signs).
549 -- The approach is to first extract the number of seconds from TS, then
550 -- add the result to SC, and finally include the remainder from TS.
551
552 -- Note that SC is always nonnegative
553
554 if TS < 0 then
555 declare
556 Seconds_From_Ts : constant Seconds_Count :=
557 Seconds_Count (abs (TS / Time_Span (Res))) +
558 (if TS rem Time_Span (Res) = 0 then 0 else 1);
559 -- Absolute value of the number of seconds in TS. Round towards
560 -- infinity so that Remainder_Ts is always positive.
561
562 Remainder_Ts : constant Time :=
563 TS + Time_Span (Seconds_From_Ts - 1) * Time_Span (Res) + Res;
564 -- Remainder from TS that needs to be added to the result once
565 -- we removed the number of seconds. Note that we do not add
566 -- Time_Span (Seconds_From_Ts) * Time_Span (Res) directly with
567 -- a single operation because for values of TS close to
568 -- Time_Span_First this multiplication would overflow.
569
570 begin
571 -- Both operands in the inner subtraction are positive. Hence,
572 -- there will be no positive overflow in SC - Seconds_From_Ts. If
573 -- there is a negative overflow then the result of adding SC and
574 -- TS would overflow anyway.
575
576 if SC < Seconds_From_Ts
577 or else Time_Last / Res < Time (SC - Seconds_From_Ts)
578 then
579 raise Constraint_Error;
580 else
581 return Time (SC - Seconds_From_Ts) * Res + Remainder_Ts;
582 end if;
583 end;
584
585 -- SC and TS are nonnegative. Check whether Time (SC) * Res overflows
586
587 elsif Time_Last / Res < Time (SC) then
588 raise Constraint_Error;
589
590 -- Both operands have the same sign, so we can convert SC into Time
591 -- right away; if this conversion overflows then the result of adding SC
592 -- and TS would overflow anyway (so we would just be detecting the
593 -- overflow a bit earlier).
594
595 else
596 return Time (SC) * Res + TS;
597 end if;
598 end Time_Of;
599
600 -----------------
601 -- To_Duration --
602 -----------------
603
604 function To_Duration (TS : Time_Span) return Duration is
605 begin
606 return
607 To_Duration
608 (Mul_Div (To_Integer (TS), Duration_Units, OSI.Ticks_Per_Second));
609 end To_Duration;
610
611 ------------------
612 -- To_Time_Span --
613 ------------------
614
615 function To_Time_Span (D : Duration) return Time_Span is
616 begin
617 return
618 Time_Span
619 (Mul_Div (To_Integer (D), OSI.Ticks_Per_Second, Duration_Units));
620 end To_Time_Span;
621
622 begin
623 -- Ensure that the tasking run time is initialized when using clock and/or
624 -- delay operations. The initialization routine has the required machinery
625 -- to prevent multiple calls to Initialize.
626
627 System.Tasking.Initialize;
628 end Ada.Real_Time;