2005-06-14 Jose Ruiz <ruiz@adacore.com>

	    Arnaud Charlet  <charlet@adacore.com>

	* a-sytaco.ads, a-sytaco.adb (Suspension_Object): These objects are no
	longer protected objects. They have been replaced by lower-level
	suspension objects made up by a mutex and a condition variable (or
	their equivalent given a particular OS) plus some internal data to
	reflect the state of the suspension object.
	(Initialize, Finalize): Add this initialization procedure for
	Suspension_Object, which is a controlled type.
	(Finalize): Add the finalization procedure for Suspension_Object,
	which is a controlled type.

	* a-sytaco-vxworks.ads, a-sytaco-vxworks.adb: Remove this version of
	Ada.Synchronous_Task_Control because there is no longer a need for a
	VxWorks specific version of this package. Target dependencies
	has been moved to System.Task_Primitives.Operations.

	* s-osinte-mingw.ads (pCRITICAL_SECTION): Remove this type which is no
	longer needed.
	(InitializeCriticalSection, EnterCriticalSection,
	LeaveCriticalSection, DeleteCriticalSection): Replace the type
	pCriticalSection by an anonymous access type so that we avoid problems
	of accessibility to local objects.

	* s-taprop.ads, s-taprop-posix.adb, s-taprop-vxworks.adb,
	s-taprop-mingw.adb, s-taprop-vms.adb, s-taprop-solaris.adb,
	s-taprop-os2.adb, s-taprop-dummy.adb, s-taprop-hpux-dce.adb,
	s-taprop-linux.adb, s-taprop-irix.adb, s-taprop-irix-athread.adb,
	s-taprop-tru64.adb, s-taprop-lynxos.adb (Elaboration Code): No longer
	set the environment task mask here.
	(Current_State): Add this function that returns the state of the
	suspension object.
	(Set_False): Add this procedure that sets the state of the suspension
	object to False.
	(Set_True): Add this procedure that sets the state of the suspension
	object to True, releasing the task that was suspended, if any.
	(Suspend_Until_True): Add this procedure that blocks the calling task
	until the state of the object is True. Program_Error is raised if
	another task is already waiting on that suspension object.
	(Initialize): Add this procedure for initializing the suspension
	object. It initializes the mutex and the condition variable which are
	used for synchronization and queuing, and it sets the internal state
	to False.
	(Finalize): Add this procedure for finalizing the suspension object,
	destroying the mutex and the condition variable.

	* s-taspri-posix.ads, s-taspri-vxworks.ads, s-taspri-mingw.ads,
	s-taspri-vms.ads, s-taspri-solaris.ads, s-taspri-os2.ads,
	s-taspri-dummy.ads, s-taspri-hpux-dce.ads, s-taspri-linux.ads,
	s-taspri-tru64.ads, s-taspri-lynxos.ads (Suspension_Object): New object
	which provides a low-level abstraction (using operating system
	primitives) for Ada.Synchronous_Task_Control.
	This object is made up by a mutex (for ensuring mutual exclusion), a
	condition variable (for queuing threads until the condition is
	signaled), a Boolean (State) indicating whether the object is open,
	and a Boolean (Waiting) reflecting whether there is a task already
	suspended on this object.

	* s-intman.ads, s-intman-irix.adb, s-intman-irix-athread.adb,
	s-intman-dummy.adb, s-intman-solaris.adb, s-intman-vms.adb,
	s-intman-vms.ads, s-intman-mingw.adb,
	(Initialize_Interrupts): Removed, no longer used.

	* s-inmaop-posix.adb, s-inmaop-vms.adb, s-inmaop-dummy.adb,
	(Setup_Interrupt_Mask): New procedure.

	* s-intman-vxworks.ads, s-intman-vxworks.adb:  Update comments.

	* s-inmaop.ads (Setup_Interrupt_Mask): New procedure

	* s-interr.adb: Add explicit call to Setup_Interrupt_Mask now that
	this is no longer done in the body of s-taprop
	(Server_Task): Explicitely test for Pending_Action in case
	System.Parameters.No_Abort is True.

	* s-taasde.adb: Add explicit call to Setup_Interrupt_Mask now that this
	is no longer done in the body of s-taprop


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@101015 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 198 insertions, 31 deletions

diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb
index ec50bae835b..889bdf23318 100644
--- a/gcc/ada/s-taprop-lynxos.adb
+++ b/gcc/ada/s-taprop-lynxos.adb
@@ -1,12 +1,12 @@
 ------------------------------------------------------------------------------
 --                                                                          --
---                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
+--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
 --                                                                          --
 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1992-2004, Free Software Foundation, Inc.          --
+--         Copyright (C) 1992-2005, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL is free software; you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -56,11 +56,6 @@ with System.Interrupt_Management;
 --           Abort_Task_Interrupt
 --           Interrupt_ID
 
-with System.Interrupt_Management.Operations;
---  used for Set_Interrupt_Mask
---           All_Tasks_Mask
-pragma Elaborate_All (System.Interrupt_Management.Operations);
-
 with System.Parameters;
 --  used for Size_Type
 
@@ -108,7 +103,7 @@ package body System.Task_Primitives.Operations is
    --  Key used to find the Ada Task_Id associated with a thread
 
    Environment_Task_Id : Task_Id;
-   --  A variable to hold Task_Id for the environment task.
+   --  A variable to hold Task_Id for the environment task
 
    Locking_Policy : Character;
    pragma Import (C, Locking_Policy, "__gl_locking_policy");
@@ -120,7 +115,7 @@ package body System.Task_Primitives.Operations is
    Unblocked_Signal_Mask : aliased sigset_t;
    --  The set of signals that should unblocked in all tasks
 
-   --  The followings are internal configuration constants needed.
+   --  The followings are internal configuration constants needed
 
    Next_Serial_Number : Task_Serial_Number := 100;
    --  We start at 100, to reserve some special values for
@@ -133,10 +128,10 @@ package body System.Task_Primitives.Operations is
    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 
    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-   --  Indicates whether FIFO_Within_Priorities is set.
+   --  Indicates whether FIFO_Within_Priorities is set
 
    Foreign_Task_Elaborated : aliased Boolean := True;
-   --  Used to identified fake tasks (i.e., non-Ada Threads).
+   --  Used to identified fake tasks (i.e., non-Ada Threads)
 
    --------------------
    -- Local Packages --
@@ -146,7 +141,7 @@ package body System.Task_Primitives.Operations is
 
       procedure Initialize (Environment_Task : Task_Id);
       pragma Inline (Initialize);
-      --  Initialize various data needed by this package.
+      --  Initialize various data needed by this package
 
       function Is_Valid_Task return Boolean;
       pragma Inline (Is_Valid_Task);
@@ -154,23 +149,23 @@ package body System.Task_Primitives.Operations is
 
       procedure Set (Self_Id : Task_Id);
       pragma Inline (Set);
-      --  Set the self id for the current task.
+      --  Set the self id for the current task
 
       function Self return Task_Id;
       pragma Inline (Self);
-      --  Return a pointer to the Ada Task Control Block of the calling task.
+      --  Return a pointer to the Ada Task Control Block of the calling task
 
    end Specific;
 
    package body Specific is separate;
-   --  The body of this package is target specific.
+   --  The body of this package is target specific
 
    ---------------------------------
    -- Support for foreign threads --
    ---------------------------------
 
    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-   --  Allocate and Initialize a new ATCB for the current Thread.
+   --  Allocate and Initialize a new ATCB for the current Thread
 
    function Register_Foreign_Thread
      (Thread : Thread_Id) return Task_Id is separate;
@@ -180,7 +175,7 @@ package body System.Task_Primitives.Operations is
    -----------------------
 
    procedure Abort_Handler (Sig : Signal);
-   --  Signal handler used to implement asynchronous abort.
+   --  Signal handler used to implement asynchronous abort
 
    procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority);
    --  This procedure calls the scheduler of the OS to set thread's priority
@@ -1016,14 +1011,194 @@ package body System.Task_Primitives.Operations is
    procedure Abort_Task (T : Task_Id) is
       Result : Interfaces.C.int;
    begin
-      Result :=
-        pthread_kill
-          (T.Common.LL.Thread,
-           Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+      Result := pthread_kill (T.Common.LL.Thread,
+         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
       pragma Assert (Result = 0);
    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. It is always initialized to False (ARM
+      --  D.10 par. 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);
+
+         if Result = ENOMEM then
+            raise Storage_Error;
+         end if;
+      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);
+
+         if Result = ENOMEM then
+            Result := pthread_condattr_destroy (Cond_Attr'Access);
+            pragma Assert (Result = 0);
+
+            raise Storage_Error;
+         end if;
+      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
+      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);
+   end Set_False;
+
+   --------------
+   -- Set_True --
+   --------------
+
+   procedure Set_True (S : in out Suspension_Object) is
+      Result : Interfaces.C.int;
+   begin
+      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);
+   end Set_True;
+
+   ------------------------
+   -- Suspend_Until_True --
+   ------------------------
+
+   procedure Suspend_Until_True (S : in out Suspension_Object) is
+      Result : Interfaces.C.int;
+   begin
+      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
+         --  (ARM D.10 par. 10).
+
+         Result := pthread_mutex_unlock (S.L'Access);
+         pragma Assert (Result = 0);
+
+         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;
+            Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+         end if;
+      end if;
+
+      Result := pthread_mutex_unlock (S.L'Access);
+      pragma Assert (Result = 0);
+   end Suspend_Until_True;
+
+   ----------------
    -- Check_Exit --
    ----------------
 
@@ -1127,7 +1302,7 @@ package body System.Task_Primitives.Operations is
    begin
       Environment_Task_Id := Environment_Task;
 
-      --  Initialize the lock used to synchronize chain of all ATCBs.
+      --  Initialize the lock used to synchronize chain of all ATCBs
 
       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
 
@@ -1138,7 +1313,7 @@ package body System.Task_Primitives.Operations is
       --  Install the abort-signal handler
 
       if State (System.Interrupt_Management.Abort_Task_Interrupt)
-                                                     /= Default
+        /= Default
       then
          act.sa_flags := 0;
          act.sa_handler := Abort_Handler'Address;
@@ -1160,15 +1335,7 @@ package body System.Task_Primitives.Operations is
 begin
    declare
       Result : Interfaces.C.int;
-
    begin
-      --  Mask Environment task for all signals. The original mask of the
-      --  Environment task will be recovered by Interrupt_Server task
-      --  during the elaboration of s-interr.adb.
-
-      System.Interrupt_Management.Operations.Set_Interrupt_Mask
-        (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
-
       --  Prepare the set of signals that should unblocked in all tasks
 
       Result := sigemptyset (Unblocked_Signal_Mask'Access);