From c840bf9bc92e71291a9dc653688bf496aa219b7d Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Fri, 20 Oct 2017 17:02:37 +0000 Subject: [PATCH] s-osinte__linux.ads (Relative_Timed_Wait): Add variable needed for using monotonic clock. gcc/ada/ 2017-10-20 Doug Rupp * libgnarl/s-osinte__linux.ads (Relative_Timed_Wait): Add variable needed for using monotonic clock. * libgnarl/s-taprop__linux.adb: Revert previous monotonic clock changes. * libgnarl/s-taprop__linux.adb, s-taprop__posix.adb: Unify and factor out monotonic clock related functions body. (Timed_Sleep, Timed_Delay, Montonic_Clock, RT_Resolution, Compute_Deadline): Move to... * libgnarl/s-tpopmo.adb: ... here. New separate package body. 2017-10-20 Ed Schonberg * sem_util.adb (Is_Controlling_Limited_Procedure): Handle properly the case where the controlling formal is an anonymous access to interface type. * exp_ch9.adb (Extract_Dispatching_Call): If controlling actual is an access type, handle properly the the constructed dereference that designates the object used in the rewritten synchronized call. (Parameter_Block_Pack): If the type of the actual is by-copy, its generated declaration in the parameter block does not need an initialization even if the type is a null-excluding access type, because it will be initialized with the value of the actual later on. (Parameter_Block_Pack): Do not add controlling actual to parameter block when its type is by-copy. 2017-10-20 Justin Squirek * sem_ch8.adb (Update_Use_Clause_Chain): Add sanity check to verify scope stack traversal into the context clause. gcc/testsuite/ 2017-10-20 Ed Schonberg * gnat.dg/sync_iface_call.adb, gnat.dg/sync_iface_call_pkg.ads, gnat.dg/sync_iface_call_pkg2.adb, gnat.dg/sync_iface_call_pkg2.ads: New testcase. From-SVN: r253948 --- gcc/ada/ChangeLog | 32 ++ gcc/ada/exp_ch9.adb | 32 +- gcc/ada/libgnarl/s-osinte__linux.ads | 3 + gcc/ada/libgnarl/s-taprop__linux.adb | 269 +++-------------- gcc/ada/libgnarl/s-taprop__posix.adb | 242 +++------------ gcc/ada/libgnarl/s-tpopmo.adb | 283 ++++++++++++++++++ gcc/ada/sem_ch8.adb | 8 +- gcc/ada/sem_util.adb | 24 +- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gnat.dg/sync_iface_call.adb | 34 +++ gcc/testsuite/gnat.dg/sync_iface_call_pkg.ads | 21 ++ .../gnat.dg/sync_iface_call_pkg2.adb | 8 + .../gnat.dg/sync_iface_call_pkg2.ads | 7 + 13 files changed, 515 insertions(+), 454 deletions(-) create mode 100644 gcc/ada/libgnarl/s-tpopmo.adb create mode 100644 gcc/testsuite/gnat.dg/sync_iface_call.adb create mode 100644 gcc/testsuite/gnat.dg/sync_iface_call_pkg.ads create mode 100644 gcc/testsuite/gnat.dg/sync_iface_call_pkg2.adb create mode 100644 gcc/testsuite/gnat.dg/sync_iface_call_pkg2.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9822cbb06d..dac7791a8e6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +2017-10-20 Doug Rupp + + * libgnarl/s-osinte__linux.ads (Relative_Timed_Wait): Add variable + needed for using monotonic clock. + * libgnarl/s-taprop__linux.adb: Revert previous monotonic clock + changes. + * libgnarl/s-taprop__linux.adb, s-taprop__posix.adb: Unify and factor + out monotonic clock related functions body. + (Timed_Sleep, Timed_Delay, Montonic_Clock, RT_Resolution, + Compute_Deadline): Move to... + * libgnarl/s-tpopmo.adb: ... here. New separate package body. + +2017-10-20 Ed Schonberg + + * sem_util.adb (Is_Controlling_Limited_Procedure): Handle properly the + case where the controlling formal is an anonymous access to interface + type. + * exp_ch9.adb (Extract_Dispatching_Call): If controlling actual is an + access type, handle properly the the constructed dereference that + designates the object used in the rewritten synchronized call. + (Parameter_Block_Pack): If the type of the actual is by-copy, its + generated declaration in the parameter block does not need an + initialization even if the type is a null-excluding access type, + because it will be initialized with the value of the actual later on. + (Parameter_Block_Pack): Do not add controlling actual to parameter + block when its type is by-copy. + +2017-10-20 Justin Squirek + + * sem_ch8.adb (Update_Use_Clause_Chain): Add sanity check to verify + scope stack traversal into the context clause. + 2017-10-20 Bob Duff * sinfo.ads: Fix a comment typo. diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index bcac6ff02b0..063b812f9bc 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -12909,11 +12909,14 @@ package body Exp_Ch9 is end if; -- If the type of the dispatching object is an access type then return - -- an explicit dereference. + -- an explicit dereference of a copy of the object, and note that + -- this is the controlling actual of the call. if Is_Access_Type (Etype (Object)) then - Object := Make_Explicit_Dereference (Sloc (N), Object); + Object := + Make_Explicit_Dereference (Sloc (N), New_Copy_Tree (Object)); Analyze (Object); + Set_Is_Controlling_Actual (Object); end if; end Extract_Dispatching_Call; @@ -14561,6 +14564,12 @@ package body Exp_Ch9 is Object_Definition => New_Occurrence_Of (Etype (Formal), Loc))); + -- The object is initialized with an explicit assignment + -- later. Indicate that it does not need an initialization + -- to prevent spurious warnings if the type excludes null. + + Set_No_Initialization (Last (Decls)); + if Ekind (Formal) /= E_Out_Parameter then -- Generate: @@ -14577,15 +14586,22 @@ package body Exp_Ch9 is Expression => New_Copy_Tree (Actual))); end if; - -- Generate: + -- If the actual is not controlling, generate: + -- Jnn'unchecked_access - Append_To (Params, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Unchecked_Access, - Prefix => New_Occurrence_Of (Temp_Nam, Loc))); + -- and add it to aggegate for access to formals. Note that + -- the actual may be by-copy but still be a controlling actual + -- if it is an access to class-wide interface. - Has_Param := True; + if not Is_Controlling_Actual (Actual) then + Append_To (Params, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Unchecked_Access, + Prefix => New_Occurrence_Of (Temp_Nam, Loc))); + + Has_Param := True; + end if; -- The controlling parameter is omitted diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads index 87da7ff01a5..a2ba537fb37 100644 --- a/gcc/ada/libgnarl/s-osinte__linux.ads +++ b/gcc/ada/libgnarl/s-osinte__linux.ads @@ -448,6 +448,9 @@ package System.OS_Interface is abstime : access timespec) return int; pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + -------------------------- -- POSIX.1c Section 13 -- -------------------------- diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index ba5a09907c1..5da10824a15 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -38,9 +38,7 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Interfaces.C; use Interfaces; -use type Interfaces.C.int; -use type Interfaces.C.long; +with Interfaces.C; use Interfaces; use type Interfaces.C.int; with System.Task_Info; with System.Tasking.Debug; @@ -112,8 +110,6 @@ 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 -- -------------------- @@ -141,6 +137,38 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + package Monotonic is + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970. This clock implementation is immune to + -- the system's clock changes. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns resolution of the underlying clock used to implement RT_Clock + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implement the semantics of the delay statement. + -- The caller should be abort-deferred and should not hold any locks. + + end Monotonic; + + package body Monotonic is separate; + ---------------------------------- -- ATCB allocation/deallocation -- ---------------------------------- @@ -169,11 +197,6 @@ 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 @@ -275,100 +298,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Handler; - ---------------------------------- - -- Compute_Base_Monotonic_Clock -- - ---------------------------------- - - function Compute_Base_Monotonic_Clock return Duration is - Aft : Duration; - Bef : Duration; - Mon : Duration; - Res_A : Interfaces.C.int; - Res_B : Interfaces.C.int; - Res_M : Interfaces.C.int; - TS_Aft : aliased timespec; - TS_Aft0 : aliased timespec; - TS_Bef : aliased timespec; - TS_Bef0 : aliased timespec; - TS_Mon : aliased timespec; - TS_Mon0 : aliased timespec; - - 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 that will cause CLOCK_REALTIME to jump - -- backwards. In the extrenmely unlikely event we call clock_gettime - -- before and after the jump the epoch, the 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); - - -- The calls to clock_gettime before the loop were no good - - if (TS_Bef0.tv_sec /= TS_Aft0.tv_sec - and then TS_Bef.tv_sec = TS_Aft.tv_sec) - - -- The most recent calls to clock_gettime were better - - 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)) - then - TS_Bef0 := TS_Bef; - TS_Aft0 := TS_Aft; - TS_Mon0 := TS_Mon; - end if; - end loop; - - Bef := To_Duration (TS_Bef0); - Mon := To_Duration (TS_Mon0); - Aft := To_Duration (TS_Aft0); - - -- Distribute the division, to avoid potential type overflow someday - - return Bef / 2 + Aft / 2 - Mon; - end Compute_Base_Monotonic_Clock; - -------------- -- Lock_RTS -- -------------- @@ -690,56 +619,7 @@ package body System.Task_Primitives.Operations is Mode : ST.Delay_Modes; Reason : System.Tasking.Task_States; Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time - Base_Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : C.int; - - begin - Timedout := True; - Yielded := False; - - Abs_Time := - (if Mode = Relative - then Duration'Min (Time, Max_Sensible_Delay) + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, - Time - Base_Monotonic_Clock)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time + Base_Monotonic_Clock <= Check_Time - or else Check_Time < Base_Time; - - if Result in 0 | EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; + Yielded : out Boolean) renames Monotonic.Timed_Sleep; ----------------- -- Timed_Delay -- @@ -751,92 +631,19 @@ package body System.Task_Primitives.Operations is procedure Timed_Delay (Self_ID : Task_Id; Time : Duration; - Mode : ST.Delay_Modes) - is - Base_Time : constant Duration := Monotonic_Clock; - Check_Time : Duration := Base_Time - Base_Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - - Result : C.int; - pragma Warnings (Off, Result); - - begin - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - Abs_Time := - (if Mode = Relative - then Time + Check_Time - else Duration'Min (Check_Time + Max_Sensible_Delay, - Time - Base_Monotonic_Clock)); - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time + Base_Monotonic_Clock <= Check_Time - or else Check_Time < Base_Time; - - pragma Assert (Result in 0 | ETIMEDOUT | EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - end Timed_Delay; + Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay; --------------------- -- Monotonic_Clock -- --------------------- - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_gettime - (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); - pragma Assert (Result = 0); - - return Base_Monotonic_Clock + To_Duration (TS); - end Monotonic_Clock; + function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock; ------------------- -- RT_Resolution -- ------------------- - function RT_Resolution return Duration is - TS : aliased timespec; - Result : C.int; - - begin - Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - - return To_Duration (TS); - end RT_Resolution; + function RT_Resolution return Duration renames Monotonic.RT_Resolution; ------------ -- Wakeup -- @@ -1612,8 +1419,6 @@ 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/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index a614507bd04..d9ee078b364 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -145,6 +145,38 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + package Monotonic is + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970. This clock implementation is immune to + -- the system's clock changes. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns resolution of the underlying clock used to implement RT_Clock + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implement the semantics of the delay statement. + -- The caller should be abort-deferred and should not hold any locks. + + end Monotonic; + + package body Monotonic is separate; + ---------------------------------- -- ATCB allocation/deallocation -- ---------------------------------- @@ -183,18 +215,6 @@ package body System.Task_Primitives.Operations is pragma Import (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); - procedure Compute_Deadline - (Time : Duration; - Mode : ST.Delay_Modes; - Check_Time : out Duration; - Abs_Time : out Duration; - Rel_Time : out Duration); - -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by - -- Time and Mode, compute the current clock reading (Check_Time), and the - -- target absolute and relative clock readings (Abs_Time, Rel_Time). The - -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time - -- is always that of CLOCK_RT_Ada. - ------------------- -- Abort_Handler -- ------------------- @@ -253,67 +273,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Handler; - ---------------------- - -- Compute_Deadline -- - ---------------------- - - procedure Compute_Deadline - (Time : Duration; - Mode : ST.Delay_Modes; - Check_Time : out Duration; - Abs_Time : out Duration; - Rel_Time : out Duration) - is - begin - Check_Time := Monotonic_Clock; - - -- Relative deadline - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - pragma Warnings (Off); - -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile - -- time known. - - -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) - - elsif Mode = Absolute_RT - or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME - then - pragma Warnings (On); - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - - -- Absolute deadline specified using the calendar clock, in the - -- case where it is not the same as the tasking clock: compensate for - -- difference between clock epochs (Base_Time - Base_Cal_Time). - - else - declare - Cal_Check_Time : constant Duration := OS_Primitives.Clock; - RT_Time : constant Duration := - Time + Check_Time - Cal_Check_Time; - - begin - Abs_Time := - Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); - - if Relative_Timed_Wait then - Rel_Time := - Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time); - end if; - end; - end if; - end Compute_Deadline; - ----------------- -- Stack_Guard -- ----------------- @@ -600,60 +559,7 @@ package body System.Task_Primitives.Operations is Mode : ST.Delay_Modes; Reason : Task_States; Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Base_Time : Duration; - Check_Time : Duration; - Abs_Time : Duration; - Rel_Time : Duration; - - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - Compute_Deadline - (Time => Time, - Mode => Mode, - Check_Time => Check_Time, - Abs_Time => Abs_Time, - Rel_Time => Rel_Time); - Base_Time := Check_Time; - - if Abs_Time > Check_Time then - Request := - To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; + Yielded : out Boolean) renames Monotonic.Timed_Sleep; ----------------- -- Timed_Delay -- @@ -665,95 +571,19 @@ package body System.Task_Primitives.Operations is procedure Timed_Delay (Self_ID : Task_Id; Time : Duration; - Mode : ST.Delay_Modes) - is - Base_Time : Duration; - Check_Time : Duration; - Abs_Time : Duration; - Rel_Time : Duration; - Request : aliased timespec; - - Result : Interfaces.C.int; - pragma Warnings (Off, Result); - - begin - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - Compute_Deadline - (Time => Time, - Mode => Mode, - Check_Time => Check_Time, - Abs_Time => Abs_Time, - Rel_Time => Rel_Time); - Base_Time := Check_Time; - - if Abs_Time > Check_Time then - Request := - To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := - pthread_cond_timedwait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access), - abstime => Request'Access); - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - end Timed_Delay; + Mode : ST.Delay_Modes) renames Monotonic.Timed_Delay; --------------------- -- Monotonic_Clock -- --------------------- - function Monotonic_Clock return Duration is - TS : aliased timespec; - 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); - end Monotonic_Clock; + function Monotonic_Clock return Duration renames Monotonic.Monotonic_Clock; ------------------- -- RT_Resolution -- ------------------- - function RT_Resolution return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - - return To_Duration (TS); - end RT_Resolution; + function RT_Resolution return Duration renames Monotonic.RT_Resolution; ------------ -- Wakeup -- diff --git a/gcc/ada/libgnarl/s-tpopmo.adb b/gcc/ada/libgnarl/s-tpopmo.adb new file mode 100644 index 00000000000..b6164aa19ed --- /dev/null +++ b/gcc/ada/libgnarl/s-tpopmo.adb @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.MONOTONIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Monotonic version of this package for Posix and Linux targets. + +separate (System.Task_Primitives.Operations) +package body Monotonic is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration); + -- Helper for Timed_Sleep and Timed_Delay: given a deadline specified by + -- Time and Mode, compute the current clock reading (Check_Time), and the + -- target absolute and relative clock readings (Abs_Time, Rel_Time). The + -- epoch for Time depends on Mode; the epoch for Check_Time and Abs_Time + -- is always that of CLOCK_RT_Ada. + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + 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); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + + begin + Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + + return To_Duration (TS); + end RT_Resolution; + + ---------------------- + -- Compute_Deadline -- + ---------------------- + + procedure Compute_Deadline + (Time : Duration; + Mode : ST.Delay_Modes; + Check_Time : out Duration; + Abs_Time : out Duration; + Rel_Time : out Duration) + is + begin + Check_Time := Monotonic_Clock; + + -- Relative deadline + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + pragma Warnings (Off); + -- Comparison "OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME" is compile + -- time known. + + -- Absolute deadline specified using the tasking clock (CLOCK_RT_Ada) + + elsif Mode = Absolute_RT + or else OSC.CLOCK_RT_Ada = OSC.CLOCK_REALTIME + then + pragma Warnings (On); + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + + -- Absolute deadline specified using the calendar clock, in the + -- case where it is not the same as the tasking clock: compensate for + -- difference between clock epochs (Base_Time - Base_Cal_Time). + + else + declare + Cal_Check_Time : constant Duration := OS_Primitives.Clock; + RT_Time : constant Duration := + Time + Check_Time - Cal_Check_Time; + + begin + Abs_Time := + Duration'Min (Check_Time + Max_Sensible_Delay, RT_Time); + + if Relative_Timed_Wait then + Rel_Time := + Duration'Min (Max_Sensible_Delay, RT_Time - Check_Time); + end if; + end; + end if; + end Compute_Deadline; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Base_Time : Duration; + Check_Time : Duration; + Abs_Time : Duration; + Rel_Time : Duration; + + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result in 0 | EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : ST.Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) + is + Base_Time : Duration; + Check_Time : Duration; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); + + begin + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + Compute_Deadline + (Time => Time, + Mode => Mode, + Check_Time => Check_Time, + Abs_Time => Abs_Time, + Rel_Time => Rel_Time); + Base_Time := Check_Time; + + if Abs_Time > Check_Time then + Request := + To_Timespec (if Relative_Timed_Wait then Rel_Time else Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + pragma Assert (Result in 0 | ETIMEDOUT | EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + end Timed_Delay; + +end Monotonic; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5f4cd47786a..bdc8aba1e1f 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -9108,10 +9108,10 @@ package body Sem_Ch8 is -- Deal with use clauses within the context area if the current -- scope is a compilation unit. - if Is_Compilation_Unit (Current_Scope) then - - pragma Assert (Scope_Stack.Last /= Scope_Stack.First); - + if Is_Compilation_Unit (Current_Scope) + and then Sloc (Scope_Stack.Table + (Scope_Stack.Last - 1).Entity) = Standard_Location + then Update_Chain_In_Scope (Scope_Stack.Last - 1); end if; end Update_Use_Clause_Chain; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 47d8f4fe56f..3698bbf16bd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13186,17 +13186,29 @@ package body Sem_Util is function Is_Controlling_Limited_Procedure (Proc_Nam : Entity_Id) return Boolean is + Param : Node_Id; Param_Typ : Entity_Id := Empty; begin if Ekind (Proc_Nam) = E_Procedure and then Present (Parameter_Specifications (Parent (Proc_Nam))) then - Param_Typ := Etype (Parameter_Type (First ( - Parameter_Specifications (Parent (Proc_Nam))))); + Param := Parameter_Type (First ( + Parameter_Specifications (Parent (Proc_Nam)))); - -- In this case where an Itype was created, the procedure call has been - -- rewritten. + -- The formal may be an anonymous access type. + + if Nkind (Param) = N_Access_Definition then + Param_Typ := Entity (Subtype_Mark (Param)); + + else + Param_Typ := Etype (Param); + end if; + + -- In the case where an Itype was created for a dispatchin call, the + -- procedure call has been rewritten. The actual may be an access to + -- interface type in which case it is the designated type that is the + -- controlling type. elsif Present (Associated_Node_For_Itype (Proc_Nam)) and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam))) @@ -13207,6 +13219,10 @@ package body Sem_Util is Param_Typ := Etype (First (Parameter_Associations (Associated_Node_For_Itype (Proc_Nam)))); + + if Ekind (Param_Typ) = E_Anonymous_Access_Type then + Param_Typ := Directly_Designated_Type (Param_Typ); + end if; end if; if Present (Param_Typ) then diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0a8f11222a8..04d7910c148 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2017-10-20 Ed Schonberg + + * gnat.dg/sync_iface_call.adb, gnat.dg/sync_iface_call_pkg.ads, + gnat.dg/sync_iface_call_pkg2.adb, gnat.dg/sync_iface_call_pkg2.ads: + New testcase. + 2017-10-20 Justin Squirek * gnat.dg/default_pkg_actual.adb, gnat.dg/default_pkg_actual2.adb: New diff --git a/gcc/testsuite/gnat.dg/sync_iface_call.adb b/gcc/testsuite/gnat.dg/sync_iface_call.adb new file mode 100644 index 00000000000..1603981892e --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_call.adb @@ -0,0 +1,34 @@ +-- { dg-do compile } + +with Sync_Iface_Call_Pkg; +with Sync_Iface_Call_Pkg2; + +procedure Sync_Iface_Call is + + Impl : access Sync_Iface_Call_Pkg.IFace'Class := + new Sync_Iface_Call_Pkg2.Impl; + Val : aliased Integer := 10; +begin + select + Impl.Do_Stuff (Val); + or + delay 10.0; + end select; + select + Impl.Do_Stuff_Access (Val'Access); + or + delay 10.0; + end select; + + select + Impl.Do_Stuff_2 (Val); + or + delay 10.0; + end select; + + select + Impl.Do_Stuff_2_Access (Val'Access); + or + delay 10.0; + end select; +end Sync_Iface_Call; diff --git a/gcc/testsuite/gnat.dg/sync_iface_call_pkg.ads b/gcc/testsuite/gnat.dg/sync_iface_call_pkg.ads new file mode 100644 index 00000000000..e392c024c79 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_call_pkg.ads @@ -0,0 +1,21 @@ +package Sync_Iface_Call_Pkg is + + type IFace is synchronized interface; + + procedure Do_Stuff + (This : in out IFace; + Value : in Integer) is null; + + procedure Do_Stuff_Access + (This : in out IFace; + Value : not null access Integer) is null; + + procedure Do_Stuff_2 + (This : not null access IFace; + Value : in Integer) is null; + + procedure Do_Stuff_2_Access + (This : not null access IFace; + Value : not null access Integer) is null; + +end Sync_Iface_Call_Pkg; diff --git a/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.adb b/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.adb new file mode 100644 index 00000000000..b3c221e5b1a --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.adb @@ -0,0 +1,8 @@ +package body Sync_Iface_Call_Pkg2 is + + task body Impl is + begin + null; + end Impl; + +end Sync_Iface_Call_Pkg2; diff --git a/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.ads b/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.ads new file mode 100644 index 00000000000..ca21b1d6d08 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sync_iface_call_pkg2.ads @@ -0,0 +1,7 @@ +with Sync_Iface_Call_Pkg; + +package Sync_Iface_Call_Pkg2 is + + task type Impl is new Sync_Iface_Call_Pkg.IFace with end; + +end Sync_Iface_Call_Pkg2; -- 2.30.2