https://gcc.gnu.org/g:6d29b3a23f2ca04a24acb5b991ca4951ff6ad059
commit r16-5376-g6d29b3a23f2ca04a24acb5b991ca4951ff6ad059 Author: Ronan Desplanques <[email protected]> Date: Fri Oct 31 16:23:44 2025 +0100 ada: Add ATC to suspension objects This patch makes suspension objects receptive to asynchronous transfers of control, i.e. aborts. It also replaces the multiple platform-dependent implementations of suspension objects with a single implementation relying on the existing abstractions RTS_Lock, Sleep and Wakeup. gcc/ada/ChangeLog: * libgnarl/a-sytaco.ads (Suspension_Object): Change components. * libgnarl/a-sytaco.adb (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): New cross-platform version. * libgnarl/s-taskin.ads (Task_States): New task state. * libgnarl/s-tasini.adb (Locked_Abort_To_Level): Adapt to new state. * libgnarl/s-taprop.ads (Is_Task_Context): New function Spec. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__dummy.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__linux.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__mingw.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__posix.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__qnx.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__rtems.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__solaris.adb (Is_Task_Context): New body. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taprop__vxworks.adb (Is_Task_Context): Remove spec. (Initialize, Finalize, Current_State, Set_False, Set_True, Suspend_Until_True): Remove. * libgnarl/s-taspri__dummy.ads (Suspension_Object): Remove. * libgnarl/s-taspri__lynxos.ads (Suspension_Object): Remove. * libgnarl/s-taspri__mingw.ads (Suspension_Object): Remove. * libgnarl/s-taspri__posix-noaltstack.ads (Suspension_Object): Remove. * libgnarl/s-taspri__posix.ads (Suspension_Object): Remove. * libgnarl/s-taspri__solaris.ads (Suspension_Object): Remove. * libgnarl/s-taspri__vxworks.ads (Suspension_Object): Remove. Diff: --- gcc/ada/libgnarl/a-sytaco.adb | 121 +++++++++++- gcc/ada/libgnarl/a-sytaco.ads | 10 +- gcc/ada/libgnarl/s-taprop.ads | 42 +---- gcc/ada/libgnarl/s-taprop__dummy.adb | 58 +----- gcc/ada/libgnarl/s-taprop__linux.adb | 197 +------------------- gcc/ada/libgnarl/s-taprop__mingw.adb | 174 +----------------- gcc/ada/libgnarl/s-taprop__posix.adb | 232 +----------------------- gcc/ada/libgnarl/s-taprop__qnx.adb | 228 +---------------------- gcc/ada/libgnarl/s-taprop__rtems.adb | 232 +----------------------- gcc/ada/libgnarl/s-taprop__solaris.adb | 193 +------------------- gcc/ada/libgnarl/s-taprop__vxworks.adb | 189 ------------------- gcc/ada/libgnarl/s-tasini.adb | 1 + gcc/ada/libgnarl/s-taskin.ads | 5 +- gcc/ada/libgnarl/s-taspri__dummy.ads | 2 - gcc/ada/libgnarl/s-taspri__lynxos.ads | 20 -- gcc/ada/libgnarl/s-taspri__mingw.ads | 22 --- gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads | 20 -- gcc/ada/libgnarl/s-taspri__posix.ads | 59 ------ gcc/ada/libgnarl/s-taspri__solaris.ads | 20 -- gcc/ada/libgnarl/s-taspri__vxworks.ads | 20 -- 20 files changed, 185 insertions(+), 1660 deletions(-) diff --git a/gcc/ada/libgnarl/a-sytaco.adb b/gcc/ada/libgnarl/a-sytaco.adb index a9ae5eaa8fbe..f8848541d1b0 100644 --- a/gcc/ada/libgnarl/a-sytaco.adb +++ b/gcc/ada/libgnarl/a-sytaco.adb @@ -31,12 +31,15 @@ with Ada.Exceptions; -with System.Tasking; -with System.Task_Primitives.Operations; +with System.Soft_Links; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; package body Ada.Synchronous_Task_Control with SPARK_Mode => Off is + use type System.Tasking.Task_Id; + + package SSL renames System.Soft_Links; ---------------- -- Initialize -- @@ -44,7 +47,9 @@ is procedure Initialize (S : in out Suspension_Object) is begin - System.Task_Primitives.Operations.Initialize (S.SO); + Initialize_Lock (S.L'Access, PO_Level); + + S.State := False; end Initialize; -------------- @@ -53,7 +58,7 @@ is procedure Finalize (S : in out Suspension_Object) is begin - System.Task_Primitives.Operations.Finalize (S.SO); + Finalize_Lock (S.L'Access); end Finalize; ------------------- @@ -62,7 +67,7 @@ is function Current_State (S : Suspension_Object) return Boolean is begin - return System.Task_Primitives.Operations.Current_State (S.SO); + return S.State; end Current_State; --------------- @@ -71,7 +76,13 @@ is procedure Set_False (S : in out Suspension_Object) is begin - System.Task_Primitives.Operations.Set_False (S.SO); + SSL.Abort_Defer.all; + Write_Lock (S.L'Access); + + S.State := False; + + Unlock (S.L'Access); + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -79,8 +90,36 @@ is -------------- procedure Set_True (S : in out Suspension_Object) is + Suspended_Task : System.Tasking.Task_Id := null; begin - System.Task_Primitives.Operations.Set_True (S.SO); + if Is_Task_Context then + SSL.Abort_Defer.all; + end if; + + Write_Lock (S.L'Access); + + if S.Suspended_Task /= null then + -- We copy the suspended task's ID to a local object. We'll wake the + -- task up right after we unlock the suspension object. + Suspended_Task := S.Suspended_Task; + S.Suspended_Task := null; + else + S.State := True; + end if; + + Unlock (S.L'Access); + + if Suspended_Task /= null then + Write_Lock (Suspended_Task); + + Wakeup (Suspended_Task, System.Tasking.Runnable); + + Unlock (Suspended_Task); + end if; + + if Is_Task_Context then + SSL.Abort_Undefer.all; + end if; end Set_True; ------------------------ @@ -88,6 +127,7 @@ is ------------------------ procedure Suspend_Until_True (S : in out Suspension_Object) is + Self_ID : constant System.Tasking.Task_Id := Self; begin -- This is a potentially blocking (see ARM D.10, par. 10), so that -- if pragma Detect_Blocking is active then Program_Error must be @@ -100,7 +140,72 @@ is (Program_Error'Identity, "potentially blocking operation"); end if; - System.Task_Primitives.Operations.Suspend_Until_True (S.SO); + SSL.Abort_Defer.all; + Write_Lock (S.L'Access); + + if S.Suspended_Task /= null then + Unlock (S.L'Access); + SSL.Abort_Undefer.all; + + raise Program_Error; + else + if S.State then + S.State := False; + + Unlock (S.L'Access); + else + Write_Lock (Self_ID); + + -- We treat starting to block in Suspend_Until_True as an abort + -- completion point, even if the language does not require it. + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + Unlock (Self_ID); + Unlock (S.L'Access); + SSL.Abort_Undefer.all; + return; + end if; + + S.Suspended_Task := Self_ID; + + Unlock (S.L'Access); + + Self_ID.Common.State := System.Tasking.Suspension_Object_Sleep; + + -- We sleep until at least one of the following propositions + -- becomes true: + -- + -- 1. We have been unsuspended by some other task calling + -- Set_True. + -- 2. We have received an abort. + loop + Sleep (Self_ID, System.Tasking.Suspension_Object_Sleep); + + Write_Lock (S.L'Access); + + -- If S.Suspended_Task /= Self_ID, we've been unsuspended by a + -- call to Set_True. S.Suspended_Task is not necessarily null + -- because some other task might have started waiting on the + -- suspension object. + if S.Suspended_Task /= Self_ID then + exit; + + -- Otherwise if we have received an abort, we must free the + -- waiting slot on the suspension object. + elsif Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + S.Suspended_Task := null; + exit; + end if; + + Unlock (S.L'Access); + end loop; + + Self_ID.Common.State := System.Tasking.Runnable; + Unlock (S.L'Access); + Unlock (Self_ID); + end if; + SSL.Abort_Undefer.all; + end if; + end Suspend_Until_True; end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/libgnarl/a-sytaco.ads b/gcc/ada/libgnarl/a-sytaco.ads index 602e31a74f4a..3528c35102e8 100644 --- a/gcc/ada/libgnarl/a-sytaco.ads +++ b/gcc/ada/libgnarl/a-sytaco.ads @@ -33,7 +33,8 @@ -- -- ------------------------------------------------------------------------------ -with System.Task_Primitives; +with System.OS_Locks; +with System.Tasking; with Ada.Task_Identification; @@ -75,10 +76,9 @@ private -- Finalization for Suspension_Object type Suspension_Object is limited record - SO : System.Task_Primitives.Suspension_Object; - -- Use low-level suspension objects so that the synchronization - -- functionality provided by this object can be achieved using - -- efficient operating system primitives. + L : aliased System.OS_Locks.RTS_Lock; + State : Boolean with Atomic; + Suspended_Task : System.Tasking.Task_Id; end record with Finalizable => diff --git a/gcc/ada/libgnarl/s-taprop.ads b/gcc/ada/libgnarl/s-taprop.ads index f88c281d0f34..c09809fffe00 100644 --- a/gcc/ada/libgnarl/s-taprop.ads +++ b/gcc/ada/libgnarl/s-taprop.ads @@ -473,38 +473,6 @@ package System.Task_Primitives.Operations is -- The call to Stack_Guard has no effect if guard pages are not used on -- the target, or if guard pages are automatically provided by the system. - ------------------------ - -- Suspension objects -- - ------------------------ - - -- These subprograms provide the functionality required for synchronizing - -- on a suspension object. Tasks can suspend execution and relinquish the - -- processors until the condition is signaled. - - function Current_State (S : Suspension_Object) return Boolean; - -- Return the state of the suspension object - - procedure Set_False (S : in out Suspension_Object); - -- Set the state of the suspension object to False - - procedure Set_True (S : in out Suspension_Object); - -- Set the state of the suspension object to True. If a task were - -- suspended on the protected object then this task is released (and - -- the state of the suspension object remains set to False). - - procedure Suspend_Until_True (S : in out Suspension_Object); - -- If the state of the suspension object is True then the calling task - -- continues its execution, and the state is set to False. If the state - -- of the object is False then the task is suspended on the suspension - -- object until a Set_True operation is executed. Program_Error is raised - -- if another task is already waiting on that suspension object. - - procedure Initialize (S : in out Suspension_Object); - -- Initialize the suspension object - - procedure Finalize (S : in out Suspension_Object); - -- Finalize the suspension object - ----------------------------------------- -- Runtime System Debugging Interfaces -- ----------------------------------------- @@ -562,4 +530,14 @@ package System.Task_Primitives.Operations is -- Ada Task Control Block. Has no effect if the underlying operating system -- does not support this capability. + function Is_Task_Context return Boolean + with Inline; + -- This function returns False if all the following points hold: + -- + -- 1. Abort_Defer should not be called in an interrupt context on the + -- current operating system. + -- 2. The current execution is in the context of an interrupt context. + -- + -- Otherwise this function returns True. + end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb index 27855d79f7fb..0478a9b0287f 100644 --- a/gcc/ada/libgnarl/s-taprop__dummy.adb +++ b/gcc/ada/libgnarl/s-taprop__dummy.adb @@ -110,15 +110,6 @@ package body System.Task_Primitives.Operations is return False; end Continue_Task; - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - return False; - end Current_State; - ---------------------- -- Environment_Task -- ---------------------- @@ -161,15 +152,6 @@ package body System.Task_Primitives.Operations is null; end Exit_Task; - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - begin - null; - end Finalize; - ------------------- -- Finalize_Lock -- ------------------- @@ -221,11 +203,6 @@ package body System.Task_Primitives.Operations is raise Program_Error with "tasking not implemented on this configuration"; end Initialize; - procedure Initialize (S : in out Suspension_Object) is - begin - null; - end Initialize; - --------------------- -- Initialize_Lock -- --------------------- @@ -345,15 +322,6 @@ package body System.Task_Primitives.Operations is null; end Set_Ceiling; - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - begin - null; - end Set_False; - ------------------ -- Set_Priority -- ------------------ @@ -376,15 +344,6 @@ package body System.Task_Primitives.Operations is null; end Set_Task_Affinity; - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - begin - null; - end Set_True; - ----------- -- Sleep -- ----------- @@ -434,15 +393,6 @@ package body System.Task_Primitives.Operations is return False; end Stop_Task; - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - begin - null; - end Suspend_Until_True; - ----------------- -- Timed_Delay -- ----------------- @@ -540,4 +490,12 @@ package body System.Task_Primitives.Operations is null; end Yield; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index 8f4c835baa79..02585d7c9c11 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -43,16 +43,9 @@ with System.OS_Primitives; with System.Task_Info; with System.Tasking.Debug; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use Interfaces; @@ -1104,188 +1097,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Result : C.int; - - begin - -- Initialize internal state (always to False (RM D.10(6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutex_init (S.L'Access, null); - - pragma Assert (Result in 0 | ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - -- Initialize internal condition variable - - Result := pthread_cond_init (S.CV'Access, null); - - pragma Assert (Result in 0 | ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). This should not - -- happen with the current Linux implementation of pthread, but - -- POSIX does not guarantee it so this may change in future. - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result in 0 | EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1545,4 +1356,12 @@ package body System.Task_Primitives.Operations is end if; end Set_Task_Affinity; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__mingw.adb b/gcc/ada/libgnarl/s-taprop__mingw.adb index a2de09bba4b2..f7deb6ea7e96 100644 --- a/gcc/ada/libgnarl/s-taprop__mingw.adb +++ b/gcc/ada/libgnarl/s-taprop__mingw.adb @@ -45,16 +45,7 @@ with System.Task_Info; with System.Tasking.Debug; with System.Win32.Ext; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization because --- the later is a higher level package that we shouldn't depend on. For --- example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is - - package SSL renames System.Soft_Links; - use Interfaces.C; use Interfaces.C.Strings; @@ -1041,163 +1032,6 @@ package body System.Task_Primitives.Operations is return Duration (1.0 / Ticks_Per_Second); end RT_Resolution; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - InitializeCriticalSection (S.L'Access); - - -- Initialize internal condition variable - - S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); - pragma Assert (S.CV /= 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : BOOL; - - begin - -- Destroy internal mutex - - DeleteCriticalSection (S.L'Access); - - -- Destroy internal condition variable - - Result := CloseHandle (S.CV); - pragma Assert (Result = Win32.TRUE); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - begin - SSL.Abort_Defer.all; - - EnterCriticalSection (S.L'Access); - - S.State := False; - - LeaveCriticalSection (S.L'Access); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : BOOL; - - begin - SSL.Abort_Defer.all; - - EnterCriticalSection (S.L'Access); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := SetEvent (S.CV); - pragma Assert (Result = Win32.TRUE); - - else - S.State := True; - end if; - - LeaveCriticalSection (S.L'Access); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : DWORD; - Result_Bool : BOOL; - - begin - SSL.Abort_Defer.all; - - EnterCriticalSection (S.L'Access); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). - - LeaveCriticalSection (S.L'Access); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - - LeaveCriticalSection (S.L'Access); - - SSL.Abort_Undefer.all; - - else - S.Waiting := True; - - -- Must reset CV BEFORE L is unlocked - - Result_Bool := ResetEvent (S.CV); - pragma Assert (Result_Bool = Win32.TRUE); - - LeaveCriticalSection (S.L'Access); - - SSL.Abort_Undefer.all; - - Result := WaitForSingleObject (S.CV, Wait_Infinite); - pragma Assert (Result = 0); - end if; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1358,4 +1192,12 @@ package body System.Task_Primitives.Operations is end if; end Set_Task_Affinity; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index 4395dc431cb5..d5c840253911 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -50,16 +50,9 @@ with System.OS_Primitives; with System.Task_Info; with System.Tasking.Debug; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use Interfaces.C; @@ -912,223 +905,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - - begin - -- Initialize internal state (always to False (RM D.10 (6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - - else - Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in (RM D.10(9)). Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1327,4 +1103,12 @@ package body System.Task_Primitives.Operations is null; end Set_Task_Affinity; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index c9a98e9eaa11..2572c1588fc7 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -51,16 +51,9 @@ with System.OS_Primitives; with System.Task_Info; with System.Tasking.Debug; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use Interfaces.C; @@ -932,223 +925,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - - begin - -- Initialize internal state (always to False (RM D.10 (6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - - else - Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in (RM D.10(9)). Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1437,4 +1213,8 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end Enable_Signals; + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb index 9b8c63abf43e..665a394cae68 100644 --- a/gcc/ada/libgnarl/s-taprop__rtems.adb +++ b/gcc/ada/libgnarl/s-taprop__rtems.adb @@ -44,16 +44,9 @@ with System.OS_Primitives; with System.Task_Info; with System.Tasking.Debug; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use Interfaces.C; @@ -922,223 +915,6 @@ package body System.Task_Primitives.Operations is end if; end Abort_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - - begin - -- Initialize internal state (always to False (RM D.10 (6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - - else - Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - -- Storage_Error is propagated as intended if the allocation of the - -- underlying OS entities fails. - - raise Storage_Error; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in (RM D.10(9)). Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1325,4 +1101,12 @@ package body System.Task_Primitives.Operations is null; end Set_Task_Affinity; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__solaris.adb b/gcc/ada/libgnarl/s-taprop__solaris.adb index 1b65100362c4..4e38d0e91e2c 100644 --- a/gcc/ada/libgnarl/s-taprop__solaris.adb +++ b/gcc/ada/libgnarl/s-taprop__solaris.adb @@ -48,16 +48,9 @@ pragma Warnings (Off); with System.OS_Lib; pragma Warnings (On); -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use Interfaces.C; @@ -1579,184 +1572,6 @@ package body System.Task_Primitives.Operations is return True; end Check_Finalize_Lock; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Initialize internal state (always to zero (RM D.10(6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error with "Failed to allocate a lock"; - end if; - - -- Initialize internal condition variable - - Result := cond_init (S.CV'Access, USYNC_THREAD, 0); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- @@ -1997,4 +1812,12 @@ package body System.Task_Primitives.Operations is end if; end Set_Task_Affinity; + --------------------- + -- Is_Task_Context -- + --------------------- + + function Is_Task_Context return Boolean is + begin + return True; + end Is_Task_Context; end System.Task_Primitives.Operations; diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb index a4dab5fa9d1e..1e96b81d97d0 100644 --- a/gcc/ada/libgnarl/s-taprop__vxworks.adb +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -45,19 +45,12 @@ with System.Multiprocessors; with System.OS_Constants; with System.Tasking.Debug; -with System.Soft_Links; --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend --- on. For example when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - with System.Task_Info; with System.VxWorks.Ext; package body System.Task_Primitives.Operations is package OSC renames System.OS_Constants; - package SSL renames System.Soft_Links; use System.OS_Interface; use System.OS_Locks; @@ -174,10 +167,6 @@ package body System.Task_Primitives.Operations is procedure Install_Signal_Handlers; -- Install the default signal handlers for the current task - function Is_Task_Context return Boolean; - -- This function returns True if the current execution is in the context of - -- a task, and False if it is an interrupt context. - type Set_Stack_Limit_Proc_Acc is access procedure; pragma Convention (C, Set_Stack_Limit_Proc_Acc); @@ -987,184 +976,6 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end Abort_Task; - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - begin - -- Initialize internal state (always to False (RM D.10(6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - -- Use simpler binary semaphore instead of VxWorks mutual exclusion - -- semaphore, because we don't need the fancier semantics and their - -- overhead. - - S.L := semBCreate (SEM_Q_FIFO, SEM_FULL); - - -- Initialize internal condition variable - - S.CV := semBCreate (SEM_Q_FIFO, SEM_EMPTY); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - pragma Unmodified (S); - -- S may be modified on other targets, but not on VxWorks - - Result : STATUS; - - begin - -- Destroy internal mutex - - Result := semDelete (S.L); - pragma Assert (Result = OK); - - -- Destroy internal condition variable - - Result := semDelete (S.CV); - pragma Assert (Result = OK); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : STATUS; - - begin - SSL.Abort_Defer.all; - - Result := semTake (S.L, WAIT_FOREVER); - pragma Assert (Result = OK); - - S.State := False; - - Result := semGive (S.L); - pragma Assert (Result = OK); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : STATUS; - - begin - -- Set_True can be called from an interrupt context, in which case - -- Abort_Defer is undefined. - - if Is_Task_Context then - SSL.Abort_Defer.all; - end if; - - Result := semTake (S.L, WAIT_FOREVER); - pragma Assert (Result = OK); - - -- If there is already a task waiting on this suspension object then we - -- resume it, leaving the state of the suspension object to False, as it - -- is specified in (RM D.10 (9)). Otherwise, it just leaves the state to - -- True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := semGive (S.CV); - pragma Assert (Result = OK); - else - S.State := True; - end if; - - Result := semGive (S.L); - pragma Assert (Result = OK); - - -- Set_True can be called from an interrupt context, in which case - -- Abort_Undefer is undefined. - - if Is_Task_Context then - SSL.Abort_Undefer.all; - end if; - - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : STATUS; - - begin - SSL.Abort_Defer.all; - - Result := semTake (S.L, WAIT_FOREVER); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := semGive (S.L); - pragma Assert (Result = OK); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (RM D.10 (9)). - - if S.State then - S.State := False; - - Result := semGive (S.L); - pragma Assert (Result = OK); - - SSL.Abort_Undefer.all; - - else - S.Waiting := True; - - -- Release the mutex before sleeping - - Result := semGive (S.L); - pragma Assert (Result = OK); - - SSL.Abort_Undefer.all; - - Result := semTake (S.CV, WAIT_FOREVER); - pragma Assert (Result = 0); - end if; - end if; - end Suspend_Until_True; - ---------------- -- Check_Exit -- ---------------- diff --git a/gcc/ada/libgnarl/s-tasini.adb b/gcc/ada/libgnarl/s-tasini.adb index ae0826590c86..f8b83a234d74 100644 --- a/gcc/ada/libgnarl/s-tasini.adb +++ b/gcc/ada/libgnarl/s-tasini.adb @@ -529,6 +529,7 @@ package body System.Tasking.Initialization is | Interrupt_Server_Blocked_Interrupt_Sleep | Interrupt_Server_Idle_Sleep | Timer_Server_Sleep + | Suspension_Object_Sleep => Wakeup (T, T.Common.State); diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index dbf2e7bf91ec..2b5e7950c01c 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -205,8 +205,11 @@ package System.Tasking is Activating, -- Task has been created and is being made Runnable - Acceptor_Delay_Sleep + Acceptor_Delay_Sleep, -- Task is waiting on an selective wait statement + + Suspension_Object_Sleep + -- Task is blocked in a call to Suspend_Until_True ); type Call_Modes is diff --git a/gcc/ada/libgnarl/s-taspri__dummy.ads b/gcc/ada/libgnarl/s-taspri__dummy.ads index 59e1f6d31a6b..b726dcb0d40e 100644 --- a/gcc/ada/libgnarl/s-taspri__dummy.ads +++ b/gcc/ada/libgnarl/s-taspri__dummy.ads @@ -38,8 +38,6 @@ package System.Task_Primitives is type Lock is new Integer; - type Suspension_Object is new Integer; - type Task_Body_Access is access procedure; type Private_Data is limited record diff --git a/gcc/ada/libgnarl/s-taspri__lynxos.ads b/gcc/ada/libgnarl/s-taspri__lynxos.ads index 4b793732a81c..eaa80953fcbd 100644 --- a/gcc/ada/libgnarl/s-taspri__lynxos.ads +++ b/gcc/ada/libgnarl/s-taspri__lynxos.ads @@ -41,9 +41,6 @@ package System.Task_Primitives is type Lock is limited private; -- Should be used for implementation of protected objects - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper declared -- local to the GNARL). @@ -67,23 +64,6 @@ private WO : aliased System.OS_Locks.RTS_Lock; end record; - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until condition is signaled - end record; - type Private_Data is limited record Thread : aliased System.OS_Interface.pthread_t; -- This component is written to once before concurrent access to it is diff --git a/gcc/ada/libgnarl/s-taspri__mingw.ads b/gcc/ada/libgnarl/s-taspri__mingw.ads index 4f3f84a99fd5..b0fe8855b0d8 100644 --- a/gcc/ada/libgnarl/s-taspri__mingw.ads +++ b/gcc/ada/libgnarl/s-taspri__mingw.ads @@ -41,9 +41,6 @@ package System.Task_Primitives is type Lock is limited private; -- Should be used for implementation of protected objects - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper -- declared local to the GNARL). @@ -87,23 +84,4 @@ private -- Condition variable used to queue threads until condition is signaled end record; - type Private_Data is limited record - Thread : aliased System.OS_Interface.Thread_Id; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - Thread_Id : aliased Win32.DWORD; - -- Used to provide a better tasking support in gdb - - CV : aliased Condition_Variable; - -- Condition Variable used to implement Sleep/Wakeup - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for all components is lock L - end record; - end System.Task_Primitives; diff --git a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads index e42bab4bc794..5899b3acd0fc 100644 --- a/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads +++ b/gcc/ada/libgnarl/s-taspri__posix-noaltstack.ads @@ -44,9 +44,6 @@ package System.Task_Primitives is type Lock is limited private; -- Should be used for implementation of protected objects - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper declared -- local to the GNARL). @@ -70,23 +67,6 @@ private WO : aliased System.OS_Locks.RTS_Lock; end record; - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until condition is signaled - end record; - type Private_Data is limited record Thread : aliased System.OS_Interface.pthread_t; -- This component is written to once before concurrent access to it is diff --git a/gcc/ada/libgnarl/s-taspri__posix.ads b/gcc/ada/libgnarl/s-taspri__posix.ads index 8ec83ed020bf..32510c96bd5e 100644 --- a/gcc/ada/libgnarl/s-taspri__posix.ads +++ b/gcc/ada/libgnarl/s-taspri__posix.ads @@ -47,9 +47,6 @@ package System.Task_Primitives is type Lock is limited private; -- Should be used for implementation of protected objects - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper declared -- local to the GNARL). @@ -73,62 +70,6 @@ private WO : aliased System.OS_Locks.RTS_Lock; end record; - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - -- - -- When reviewing how this component is used, one should keep in mind - -- RM D.10 (10.2/5), which allows us to tolerate some race conditions - -- that can potentially cause deadlocks. - -- - -- For example, consider the following code: - -- - -- SO : Suspension_Object; - -- - -- task A; - -- task B; - -- - -- task body A is - -- begin - -- Suspend_Until_True (SO); - -- end A; - -- - -- task body B is - -- begin - -- Set_True (SO); - -- Suspend_Until_True (SO); - -- end B; - -- - -- One might be worried about the following ordering of events: - -- - A enters Suspend_Until_True and starts waiting on the condition - -- variable - -- - B calls Set_True, which sets Waiting to False and signals the - -- condvar. - -- - The scheduler keeps running B. B enters Suspend_Until_True and sets - -- Waiting to True again. - -- - A wakes up from pthread_cond_wait, sees that Waiting is True, so - -- concludes that the wakeup was spurious and starts waiting again, - -- effectively missing B's Set_True. - -- - -- But this is in fact not a problem because the code falls into the - -- category described by RM D.10 (10.2/5): if the first thing to happen - -- is B's call to Set_True, the two remaining calls to - -- Suspend_Until_True clearly happen concurrently, which is the bounded - -- error case. - - L : aliased System.OS_Locks.RTS_Lock; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until condition is signaled - end record; - type Private_Data is limited record Thread : aliased System.OS_Interface.pthread_t; -- This component is written to once before concurrent access to it is diff --git a/gcc/ada/libgnarl/s-taspri__solaris.ads b/gcc/ada/libgnarl/s-taspri__solaris.ads index c48b1f640beb..cc7f9f9e5c21 100644 --- a/gcc/ada/libgnarl/s-taspri__solaris.ads +++ b/gcc/ada/libgnarl/s-taspri__solaris.ads @@ -50,9 +50,6 @@ package System.Task_Primitives is function To_RTS_Lock_Ptr is new Ada.Unchecked_Conversion (Lock_Ptr, OS_Locks.RTS_Lock_Ptr); - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper -- declared local to the GNARL). @@ -73,23 +70,6 @@ private type Lock is new OS_Locks.RTS_Lock; - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Interface.mutex_t; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.cond_t; - -- Condition variable used to queue threads until condition is signaled - end record; - -- Note that task support on gdb relies on the fact that the first two -- fields of Private_Data are Thread and LWP. diff --git a/gcc/ada/libgnarl/s-taspri__vxworks.ads b/gcc/ada/libgnarl/s-taspri__vxworks.ads index 2bd503ebd903..e202c69d8b1e 100644 --- a/gcc/ada/libgnarl/s-taspri__vxworks.ads +++ b/gcc/ada/libgnarl/s-taspri__vxworks.ads @@ -40,9 +40,6 @@ package System.Task_Primitives is type Lock is limited private; -- Should be used for implementation of protected objects - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - type Task_Body_Access is access procedure; -- Pointer to the task body's entry point (or possibly a wrapper -- declared local to the GNARL). @@ -63,23 +60,6 @@ private type Lock is new System.OS_Locks.RTS_Lock; - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Interface.SEM_ID; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.SEM_ID; - -- Condition variable used to queue threads until condition is signaled - end record; - type Private_Data is limited record Thread : aliased System.OS_Interface.t_id := 0; pragma Atomic (Thread);
