From f7fb5c08f36ea1c1aeebe1710839d1c0d5e68674 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Mon, 25 Sep 2017 08:46:40 +0000 Subject: [PATCH] [multiple changes] 2017-09-25 Bob Duff * exp_ch3.adb: Rename Comp_Type_Simple to be Comp_Simple_Init. 2017-09-25 Doug Rupp * 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. From-SVN: r253136 --- gcc/ada/ChangeLog | 13 ++++ gcc/ada/exp_ch3.adb | 13 ++-- gcc/ada/libgnarl/s-taprop__linux.adb | 98 +++++++++++++++++++++++++--- gcc/ada/s-oscons-tmplt.c | 3 +- 4 files changed, 114 insertions(+), 13 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5f0b861027c..371d50ec30e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2017-09-25 Bob Duff + + * exp_ch3.adb: Rename Comp_Type_Simple to be Comp_Simple_Init. + +2017-09-25 Doug Rupp + + * 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. + 2017-09-25 Ed Schonberg * sem_ch12.adb (Save_References_In_Aggregate): Small correction to diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 33948bd14d6..39ad94a3437 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -517,11 +517,16 @@ package body Exp_Ch3 is procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is Comp_Type : constant Entity_Id := Component_Type (A_Type); - Comp_Type_Simple : constant Boolean := + Comp_Simple_Init : constant Boolean := Needs_Simple_Initialization (T => Comp_Type, Consider_IS => not (Validity_Check_Copies and Is_Bit_Packed_Array (A_Type))); + -- True if the component needs simple initialization, based on its type, + -- plus the fact that we do not do simple initialization for components + -- of bit-packed arrays when validity checks are enabled, because the + -- initialization with deliberately out-of-range values would raise + -- Constraint_Error. Body_Stmts : List_Id; Has_Default_Init : Boolean; @@ -563,7 +568,7 @@ package body Exp_Ch3 is Convert_To (Comp_Type, Default_Aspect_Component_Value (First_Subtype (A_Type))))); - elsif Comp_Type_Simple then + elsif Comp_Simple_Init then Set_Assignment_OK (Comp); return New_List ( Make_Assignment_Statement (Loc, @@ -595,7 +600,7 @@ package body Exp_Ch3 is -- the dummy Init_Proc needed for Initialize_Scalars processing. if not Has_Non_Null_Base_Init_Proc (Comp_Type) - and then not Comp_Type_Simple + and then not Comp_Simple_Init and then not Has_Task (Comp_Type) and then not Has_Default_Aspect (A_Type) then @@ -685,7 +690,7 @@ package body Exp_Ch3 is -- init_proc. Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) - or else Comp_Type_Simple + or else Comp_Simple_Init or else Has_Task (Comp_Type) or else Has_Default_Aspect (A_Type); diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index cc49205cf0a..4f83d73b674 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -64,6 +64,7 @@ package body System.Task_Primitives.Operations is use System.Parameters; use System.OS_Primitives; use System.Task_Info; + use type Interfaces.C.long; ---------------- -- Local Data -- @@ -110,6 +111,8 @@ package body System.Task_Primitives.Operations is -- Constant to indicate that the thread identifier has not yet been -- initialized. + Base_Monotonic_Clock : Duration := 0.0; + -------------------- -- Local Packages -- -------------------- @@ -160,6 +163,12 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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 @@ package body System.Task_Primitives.Operations is 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); diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index 0ace0b632eb..444ad6072d4 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -1440,7 +1440,8 @@ CND(CLOCK_FASTEST, "Fastest clock") #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 -- 2.30.2