[Ada] Use the Monotonic Clock on Linux

Pierre-Marie de Rodat derodat@adacore.com
Mon Sep 25 08:47:00 GMT 2017


The monotonic clock epoch is set to some undetermined time
in the past (typically system boot time).  In order to use the
monotonic clock for absolute time, the offset from a known epoch
is calculated and incorporated into timed delay and sleep.

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-09-25  Doug Rupp  <rupp@adacore.com>

	* libgnarl/s-taprop__linux.adb (Base_Monotonic_Clock): New variable.
	(Compute_Base_Monotonic_Clock): New function.
	(Timed_Sleep): Adjust to use Base_Monotonic_Clock.
	(Timed_Delay): Likewise.
	(Monotonic_Clock): Likewise.
	* s-oscons-tmplt.c (CLOCK_MONOTONIC): Use on Linux.

-------------- next part --------------
Index: s-oscons-tmplt.c
===================================================================
--- s-oscons-tmplt.c	(revision 253134)
+++ s-oscons-tmplt.c	(working copy)
@@ -1440,7 +1440,8 @@
 #endif
 CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock")
 
-#if defined(__FreeBSD__) || (defined(_AIX) && defined(_AIXVERSION_530)) \
+#if defined(__linux__) || defined(__FreeBSD__) \
+ || (defined(_AIX) && defined(_AIXVERSION_530)) \
  || defined(__DragonFly__)
 /** On these platforms use system provided monotonic clock instead of
  ** the default CLOCK_REALTIME. We then need to set up cond var attributes
Index: libgnarl/s-taprop__linux.adb
===================================================================
--- libgnarl/s-taprop__linux.adb	(revision 253134)
+++ libgnarl/s-taprop__linux.adb	(working copy)
@@ -64,6 +64,7 @@
    use System.Parameters;
    use System.OS_Primitives;
    use System.Task_Info;
+   use type Interfaces.C.long;
 
    ----------------
    -- Local Data --
@@ -110,6 +111,8 @@
    --  Constant to indicate that the thread identifier has not yet been
    --  initialized.
 
+   Base_Monotonic_Clock : Duration := 0.0;
+
    --------------------
    -- Local Packages --
    --------------------
@@ -160,6 +163,12 @@
 
    procedure Abort_Handler (signo : Signal);
 
+   function Compute_Base_Monotonic_Clock return Duration;
+   --  The monotonic clock epoch is set to some undetermined time
+   --  in the past (typically system boot time).  In order to use the
+   --  monotonic clock for absolute time, the offset from a known epoch
+   --  is needed.
+
    function GNAT_pthread_condattr_setup
      (attr : access pthread_condattr_t) return C.int;
    pragma Import
@@ -257,6 +266,73 @@
       end if;
    end Abort_Handler;
 
+   ----------------------------------
+   -- Compute_Base_Monotonic_Clock --
+   ----------------------------------
+
+   function Compute_Base_Monotonic_Clock return Duration is
+      TS_Bef0, TS_Mon0, TS_Aft0 : aliased timespec;
+      TS_Bef,  TS_Mon,  TS_Aft  : aliased timespec;
+      Bef, Mon, Aft             : Duration;
+      Res_B, Res_M, Res_A       : Interfaces.C.int;
+   begin
+      Res_B := clock_gettime
+       (clock_id => OSC.CLOCK_REALTIME, tp => TS_Bef0'Unchecked_Access);
+      pragma Assert (Res_B = 0);
+      Res_M := clock_gettime
+       (clock_id => OSC.CLOCK_RT_Ada, tp => TS_Mon0'Unchecked_Access);
+      pragma Assert (Res_M = 0);
+      Res_A := clock_gettime
+       (clock_id => OSC.CLOCK_REALTIME, tp => TS_Aft0'Unchecked_Access);
+      pragma Assert (Res_A = 0);
+
+      for I in 1 .. 10 loop
+         --  Guard against a leap second which will cause CLOCK_REALTIME
+         --  to jump backwards.  In the extrenmely unlikely event we call
+         --  clock_gettime before and after the jump the epoch result will
+         --  be off slightly.
+         --  Use only results where the tv_sec values match for the sake
+         --  of convenience.
+         --  Also try to calculate the most accurate
+         --  epoch by taking the minimum difference of 10 tries.
+
+         Res_B := clock_gettime
+          (clock_id => OSC.CLOCK_REALTIME, tp => TS_Bef'Unchecked_Access);
+         pragma Assert (Res_B = 0);
+         Res_M := clock_gettime
+          (clock_id => OSC.CLOCK_RT_Ada, tp => TS_Mon'Unchecked_Access);
+         pragma Assert (Res_M = 0);
+         Res_A := clock_gettime
+          (clock_id => OSC.CLOCK_REALTIME, tp => TS_Aft'Unchecked_Access);
+         pragma Assert (Res_A = 0);
+
+         if (TS_Bef0.tv_sec /= TS_Aft0.tv_sec and then
+             TS_Bef.tv_sec  = TS_Aft.tv_sec)
+            --  The calls to clock_gettime before the loop were no good.
+            or else
+            (TS_Bef0.tv_sec = TS_Aft0.tv_sec and then
+             TS_Bef.tv_sec  = TS_Aft.tv_sec and then
+            (TS_Aft.tv_nsec  - TS_Bef.tv_nsec <
+             TS_Aft0.tv_nsec - TS_Bef0.tv_nsec))
+            --  The most recent calls to clock_gettime were more better.
+         then
+            TS_Bef0.tv_sec := TS_Bef.tv_sec;
+            TS_Bef0.tv_nsec := TS_Bef.tv_nsec;
+            TS_Aft0.tv_sec := TS_Aft.tv_sec;
+            TS_Aft0.tv_nsec := TS_Aft.tv_nsec;
+            TS_Mon0.tv_sec := TS_Mon.tv_sec;
+            TS_Mon0.tv_nsec := TS_Mon.tv_nsec;
+         end if;
+      end loop;
+
+      Bef := To_Duration (TS_Bef0);
+      Mon := To_Duration (TS_Mon0);
+      Aft := To_Duration (TS_Aft0);
+
+      return Bef / 2 + Aft / 2 - Mon;
+      --  Distribute the division to avoid potential type overflow someday.
+   end Compute_Base_Monotonic_Clock;
+
    --------------
    -- Lock_RTS --
    --------------
@@ -583,7 +659,7 @@
       pragma Unreferenced (Reason);
 
       Base_Time  : constant Duration := Monotonic_Clock;
-      Check_Time : Duration := Base_Time;
+      Check_Time : Duration := Base_Time - Base_Monotonic_Clock;
       Abs_Time   : Duration;
       Request    : aliased timespec;
       Result     : C.int;
@@ -595,7 +671,8 @@
       Abs_Time :=
         (if Mode = Relative
          then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
-         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+         else Duration'Min (Check_Time + Max_Sensible_Delay,
+                            Time - Base_Monotonic_Clock));
 
       if Abs_Time > Check_Time then
          Request := To_Timespec (Abs_Time);
@@ -612,7 +689,8 @@
                  abstime => Request'Access);
 
             Check_Time := Monotonic_Clock;
-            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+            exit when Abs_Time + Base_Monotonic_Clock <= Check_Time
+                      or else Check_Time < Base_Time;
 
             if Result in 0 | EINTR then
 
@@ -640,7 +718,7 @@
       Mode    : ST.Delay_Modes)
    is
       Base_Time  : constant Duration := Monotonic_Clock;
-      Check_Time : Duration := Base_Time;
+      Check_Time : Duration := Base_Time - Base_Monotonic_Clock;
       Abs_Time   : Duration;
       Request    : aliased timespec;
 
@@ -657,7 +735,8 @@
       Abs_Time :=
         (if Mode = Relative
          then Time + Check_Time
-         else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
+         else Duration'Min (Check_Time + Max_Sensible_Delay,
+                            Time - Base_Monotonic_Clock));
 
       if Abs_Time > Check_Time then
          Request := To_Timespec (Abs_Time);
@@ -675,7 +754,8 @@
                  abstime => Request'Access);
 
             Check_Time := Monotonic_Clock;
-            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+            exit when Abs_Time + Base_Monotonic_Clock <= Check_Time
+                      or else Check_Time < Base_Time;
 
             pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
          end loop;
@@ -698,13 +778,13 @@
 
    function Monotonic_Clock return Duration is
       TS     : aliased timespec;
-      Result : C.int;
+      Result : Interfaces.C.int;
    begin
       Result := clock_gettime
         (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
       pragma Assert (Result = 0);
 
-      return To_Duration (TS);
+      return Base_Monotonic_Clock + To_Duration (TS);
    end Monotonic_Clock;
 
    -------------------
@@ -1496,6 +1576,8 @@
 
       Interrupt_Management.Initialize;
 
+      Base_Monotonic_Clock := Compute_Base_Monotonic_Clock;
+
       --  Prepare the set of signals that should be unblocked in all tasks
 
       Result := sigemptyset (Unblocked_Signal_Mask'Access);


More information about the Gcc-patches mailing list