From: Ronan Desplanques <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 --
.../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 a9ae5eaa8fb..f8848541d1b 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 602e31a74f4..3528c35102e 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 f88c281d0f3..c09809fffe0 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 27855d79f7f..0478a9b0287 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 8f4c835baa7..02585d7c9c1 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 a2de09bba4b..f7deb6ea7e9 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 4395dc431cb..d5c84025391 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 c9a98e9eaa1..2572c1588fc 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 9b8c63abf43..665a394cae6 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 1b65100362c..4e38d0e91e2 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 a4dab5fa9d1..1e96b81d97d 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 ae0826590c8..f8b83a234d7 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 dbf2e7bf91e..2b5e7950c01 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 59e1f6d31a6..b726dcb0d40 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 4b793732a81..eaa80953fcb 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 4f3f84a99fd..b0fe8855b0d 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 e42bab4bc79..5899b3acd0f 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 8ec83ed020b..32510c96bd5 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 c48b1f640be..cc7f9f9e5c2 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 2bd503ebd90..e202c69d8b1 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);
--
2.51.0
