diff options
| author | Jose Ruiz <ruiz@adacore.com> | 2005-06-16 10:28:24 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-06-16 10:28:24 +0200 |
| commit | b497b46043b4679353aecf4be76266686813bdf3 (patch) | |
| tree | 4fb352539eb2da55b0cd66a4286daa9a48c396d2 | |
| parent | 3084fecdb96ba949ce9188b6356121c911cdff76 (diff) | |
| download | gcc-b497b46043b4679353aecf4be76266686813bdf3.tar.gz | |
a-sytaco.ads, [...] (Suspension_Object): These objects are no longer protected objects.
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
From-SVN: r101015
46 files changed, 2650 insertions, 778 deletions
diff --git a/gcc/ada/a-sytaco-vxworks.adb b/gcc/ada/a-sytaco-vxworks.adb deleted file mode 100644 index fcb320a97ec..00000000000 --- a/gcc/ada/a-sytaco-vxworks.adb +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNTIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; - -package body Ada.Synchronous_Task_Control is - use System.OS_Interface; - use type Interfaces.C.int; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - St : STATUS; - Result : Boolean := False; - - begin - -- Determine state by attempting to take the semaphore with - -- a 0 timeout value. Status = OK indicates the semaphore was - -- full, so reset it to the full state. - - St := semTake (S.Sema, NO_WAIT); - - -- If we took the semaphore, reset semaphore state to FULL - - if St = OK then - Result := True; - St := semGive (S.Sema); - end if; - - return Result; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - St : STATUS; - - begin - -- Need to get the semaphore into the "empty" state. - -- On return, this task will have made the semaphore - -- empty (St = OK) or have left it empty. - - St := semTake (S.Sema, NO_WAIT); - pragma Assert (St = OK); - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - St : STATUS; - pragma Unreferenced (St); - begin - St := semGive (S.Sema); - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - St : STATUS; - - begin - -- Determine whether another task is pending on the suspension - -- object. Should never be called from an ISR. Therefore semTake can - -- be called on the mutex - - St := semTake (S.Mutex, NO_WAIT); - - if St = OK then - - -- Wait for suspension object - - St := semTake (S.Sema, WAIT_FOREVER); - St := semGive (S.Mutex); - - else - -- Another task is pending on the suspension object - - raise Program_Error; - end if; - end Suspend_Until_True; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - begin - S.Sema := semBCreate (SEM_Q_FIFO, SEM_EMPTY); - - -- Use simpler binary semaphore instead of VxWorks - -- mutual exclusion semaphore, because we don't need - -- the fancier semantics and their overhead. - - S.Mutex := semBCreate (SEM_Q_FIFO, SEM_FULL); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - St : STATUS; - pragma Unreferenced (St); - begin - St := semDelete (S.Sema); - St := semDelete (S.Mutex); - end Finalize; - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco-vxworks.ads b/gcc/ada/a-sytaco-vxworks.ads deleted file mode 100644 index c3c54bee43c..00000000000 --- a/gcc/ada/a-sytaco-vxworks.ads +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.OS_Interface; -with Ada.Finalization; -package Ada.Synchronous_Task_Control is - - type Suspension_Object is limited private; - - procedure Set_True (S : in out Suspension_Object); - - procedure Set_False (S : in out Suspension_Object); - - function Current_State (S : Suspension_Object) return Boolean; - - procedure Suspend_Until_True (S : in out Suspension_Object); - -private - - procedure Initialize (S : in out Suspension_Object); - - procedure Finalize (S : in out Suspension_Object); - - -- Implement with a VxWorks binary semaphore. A second semaphore - -- is used to avoid a race condition related to the implementation of - -- the STC requirement to raise Program_Error when Suspend_Until_True is - -- called with a task already pending on the suspension object - - type Suspension_Object is new Ada.Finalization.Controlled with record - Sema : System.OS_Interface.SEM_ID; - Mutex : System.OS_Interface.SEM_ID; - end record; - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco.adb b/gcc/ada/a-sytaco.adb index 2b2fb271291..c3ea8faca4c 100644 --- a/gcc/ada/a-sytaco.adb +++ b/gcc/ada/a-sytaco.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNAT RUNTIME COMPONENTS -- +-- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -31,65 +31,47 @@ -- -- ------------------------------------------------------------------------------ +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules! -package body Ada.Synchronous_Task_Control is - - ------------------- - -- Suspension_PO -- - ------------------- - - protected body Suspension_Object is - - -------------- - -- Get_Open -- - -------------- - - function Get_Open return Boolean is - begin - return Open; - end Get_Open; +with System.Tasking; +-- Used for Detect_Blocking +-- Self - --------------- - -- Set_False -- - --------------- +with Ada.Exceptions; +-- Used for Raise_Exception - procedure Set_False is - begin - Open := False; - end Set_False; +with System.Task_Primitives.Operations; +-- Used for Initialize +-- Finalize +-- Current_State +-- Set_False +-- Set_True +-- Suspend_Until_True - -------------- - -- Set_True -- - -------------- +pragma Warnings (On); - procedure Set_True is - begin - Open := True; - end Set_True; - - ---------- - -- Wait -- - ---------- - - entry Wait when Open is - begin - Open := False; - end Wait; +package body Ada.Synchronous_Task_Control is - -------------------- - -- Wait_Exception -- - -------------------- + ---------------- + -- Initialize -- + ---------------- - entry Wait_Exception when True is - begin - if Wait'Count /= 0 then - raise Program_Error; - end if; + procedure Initialize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Initialize (S.SO); + end Initialize; - requeue Wait; - end Wait_Exception; + -------------- + -- Finalize -- + -------------- - end Suspension_Object; + procedure Finalize (S : in out Suspension_Object) is + begin + System.Task_Primitives.Operations.Finalize (S.SO); + end Finalize; ------------------- -- Current_State -- @@ -97,7 +79,7 @@ package body Ada.Synchronous_Task_Control is function Current_State (S : Suspension_Object) return Boolean is begin - return S.Get_Open; + return System.Task_Primitives.Operations.Current_State (S.SO); end Current_State; --------------- @@ -106,7 +88,7 @@ package body Ada.Synchronous_Task_Control is procedure Set_False (S : in out Suspension_Object) is begin - S.Set_False; + System.Task_Primitives.Operations.Set_False (S.SO); end Set_False; -------------- @@ -115,7 +97,7 @@ package body Ada.Synchronous_Task_Control is procedure Set_True (S : in out Suspension_Object) is begin - S.Set_True; + System.Task_Primitives.Operations.Set_True (S.SO); end Set_True; ------------------------ @@ -124,7 +106,18 @@ package body Ada.Synchronous_Task_Control is procedure Suspend_Until_True (S : in out Suspension_Object) is begin - S.Wait_Exception; + -- This is a potentially blocking (see ARM D.10, par. 10), so that + -- if pragma Detect_Blocking is active then Program_Error must be + -- raised if this operation is called from a protected action. + + if System.Tasking.Detect_Blocking + and then System.Tasking.Self.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + + System.Task_Primitives.Operations.Suspend_Until_True (S.SO); end Suspend_Until_True; end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads index b3a6a480a65..98eda726b9a 100644 --- a/gcc/ada/a-sytaco.ads +++ b/gcc/ada/a-sytaco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -35,9 +35,22 @@ -- -- ------------------------------------------------------------------------------ -with System; +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be implicitly categorized as Preelaborate. See AI-362 for +-- details. It is safe in the context of the run-time to violate the rules! + +with System.Task_Primitives; +-- Used for Suspension_Object + +with Ada.Finalization; +-- Used for Limited_Controlled + +pragma Warnings (On); package Ada.Synchronous_Task_Control is +pragma Preelaborate_05 (Synchronous_Task_Control); +-- In accordance with Ada 2005 AI-362 type Suspension_Object is limited private; @@ -51,19 +64,25 @@ package Ada.Synchronous_Task_Control is private - -- ??? Using a protected object is overkill; suspension could be - -- implemented more efficiently. + procedure Initialize (S : in out Suspension_Object); + -- Initialization for Suspension_Object + + procedure Finalize (S : in out Suspension_Object); + -- Finalization for Suspension_Object - protected type Suspension_Object is - entry Wait; - procedure Set_False; - procedure Set_True; - function Get_Open return Boolean; - entry Wait_Exception; + type Suspension_Object is + new Ada.Finalization.Limited_Controlled with 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. + end record; - pragma Priority (System.Any_Priority'Last); - private - Open : Boolean := False; - end Suspension_Object; + pragma Inline (Set_True); + pragma Inline (Set_False); + pragma Inline (Current_State); + pragma Inline (Suspend_Until_True); + pragma Inline (Initialize); + pragma Inline (Finalize); end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/s-inmaop-dummy.adb b/gcc/ada/s-inmaop-dummy.adb index f99a104f671..c7e125b6a2a 100644 --- a/gcc/ada/s-inmaop-dummy.adb +++ b/gcc/ada/s-inmaop-dummy.adb @@ -1,12 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- +-- O P E R A T I O N S -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001 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- -- @@ -31,7 +32,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a NO tasking version of this package. +-- This is a NO tasking version of this package package body System.Interrupt_Management.Operations is @@ -191,4 +192,13 @@ package body System.Interrupt_Management.Operations is null; end Interrupt_Self_Process; + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + null; + end Setup_Interrupt_Mask; + end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb index 8fe6b3a89bd..987fb717bf0 100644 --- a/gcc/ada/s-inmaop-posix.adb +++ b/gcc/ada/s-inmaop-posix.adb @@ -1,13 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- +-- O P E R A T I O N S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -78,7 +79,6 @@ package body System.Interrupt_Management.Operations is is Result : Interfaces.C.int; Mask : aliased sigset_t; - begin Result := sigemptyset (Mask'Access); pragma Assert (Result = 0); @@ -97,7 +97,6 @@ package body System.Interrupt_Management.Operations is is Mask : aliased sigset_t; Result : Interfaces.C.int; - begin Result := sigemptyset (Mask'Access); pragma Assert (Result = 0); @@ -113,7 +112,6 @@ package body System.Interrupt_Management.Operations is procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is Result : Interfaces.C.int; - begin Result := pthread_sigmask (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null); @@ -125,7 +123,6 @@ package body System.Interrupt_Management.Operations is OMask : access Interrupt_Mask) is Result : Interfaces.C.int; - begin Result := pthread_sigmask (SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask)); @@ -138,7 +135,6 @@ package body System.Interrupt_Management.Operations is procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is Result : Interfaces.C.int; - begin Result := pthread_sigmask (SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask)); @@ -155,7 +151,6 @@ package body System.Interrupt_Management.Operations is is Result : Interfaces.C.int; Sig : aliased Signal; - begin Result := sigwait (Mask, Sig'Access); @@ -172,7 +167,6 @@ package body System.Interrupt_Management.Operations is procedure Install_Default_Action (Interrupt : Interrupt_ID) is Result : Interfaces.C.int; - begin Result := sigaction (Signal (Interrupt), @@ -186,7 +180,6 @@ package body System.Interrupt_Management.Operations is procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is Result : Interfaces.C.int; - begin Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null); pragma Assert (Result = 0); @@ -198,7 +191,6 @@ package body System.Interrupt_Management.Operations is procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is Result : Interfaces.C.int; - begin Result := sigfillset (Mask); pragma Assert (Result = 0); @@ -210,7 +202,6 @@ package body System.Interrupt_Management.Operations is procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is Result : Interfaces.C.int; - begin Result := sigemptyset (Mask); pragma Assert (Result = 0); @@ -225,7 +216,6 @@ package body System.Interrupt_Management.Operations is Interrupt : Interrupt_ID) is Result : Interfaces.C.int; - begin Result := sigaddset (Mask, Signal (Interrupt)); pragma Assert (Result = 0); @@ -240,7 +230,6 @@ package body System.Interrupt_Management.Operations is Interrupt : Interrupt_ID) is Result : Interfaces.C.int; - begin Result := sigdelset (Mask, Signal (Interrupt)); pragma Assert (Result = 0); @@ -255,7 +244,6 @@ package body System.Interrupt_Management.Operations is Interrupt : Interrupt_ID) return Boolean is Result : Interfaces.C.int; - begin Result := sigismember (Mask, Signal (Interrupt)); pragma Assert (Result = 0 or else Result = 1); @@ -268,8 +256,7 @@ package body System.Interrupt_Management.Operations is procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; - Y : Interrupt_Mask) - is + Y : Interrupt_Mask) is begin X := Y; end Copy_Interrupt_Mask; @@ -280,12 +267,24 @@ package body System.Interrupt_Management.Operations is procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is Result : Interfaces.C.int; - begin Result := kill (getpid, Signal (Interrupt)); pragma Assert (Result = 0); end Interrupt_Self_Process; + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + -- Mask task for all signals. The original mask of the Environment task + -- will be recovered by Interrupt_Manager task during the elaboration + -- of s-interr.adb. + + Set_Interrupt_Mask (All_Tasks_Mask'Access); + end Setup_Interrupt_Mask; + begin declare diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb index 044eac7d037..277d8865b9e 100644 --- a/gcc/ada/s-inmaop-vms.adb +++ b/gcc/ada/s-inmaop-vms.adb @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- -- 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- -- @@ -268,9 +268,9 @@ package body System.Interrupt_Management.Operations is X := Y; end Copy_Interrupt_Mask; - ------------------------- + ---------------------------- -- Interrupt_Self_Process -- - ------------------------- + ---------------------------- procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is Status : Cond_Value_Type; @@ -285,6 +285,15 @@ package body System.Interrupt_Management.Operations is pragma Assert ((Status and 1) = 1); end Interrupt_Self_Process; + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + null; + end Setup_Interrupt_Mask; + begin Environment_Mask := (others => False); All_Tasks_Mask := (others => True); diff --git a/gcc/ada/s-inmaop.ads b/gcc/ada/s-inmaop.ads index 2bb8ef0caa1..0c8f6ee5377 100644 --- a/gcc/ada/s-inmaop.ads +++ b/gcc/ada/s-inmaop.ads @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- -- O P E R A T I O N S -- -- -- -- S p e c -- -- -- --- 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- -- @@ -103,6 +103,11 @@ package System.Interrupt_Management.Operations is pragma Inline (Interrupt_Self_Process); -- Raise an Interrupt process-level + procedure Setup_Interrupt_Mask; + -- Mask Environment task for all signals + -- This function should be called by the elaboration of System.Interrupt + -- to set up proper signal masking in all tasks. + -- The following objects serve as constants, but are initialized -- in the body to aid portability. These actually belong to the -- System.Interrupt_Management but since Interrupt_Mask is a diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index de93ca1ecc8..fdff2748120 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T S -- -- -- @@ -1438,8 +1438,13 @@ package body System.Interrupts is System.Tasking.Initialization.Undefer_Abort (Self_ID); - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. + if Self_ID.Pending_Action then + Initialization.Do_Pending_Action (Self_ID); + end if; + + -- Undefer abort here to allow a window for this task to be aborted + -- at the time of system shutdown. We also explicitely test for + -- Pending_Action in case System.Parameters.No_Abort is True. end loop; end Server_Task; @@ -1454,16 +1459,15 @@ begin -- During the elaboration of this package body we want the RTS -- to inherit the interrupt mask from the Environment Task. - -- The environment task should have gotten its mask from - -- the enclosing process during the RTS start up. (See - -- processing in s-inmaop.adb). Pass the Interrupt_Mask - -- of the environment task to the Interrupt_Manager. + IMOP.Setup_Interrupt_Mask; + + -- The environment task should have gotten its mask from the enclosing + -- process during the RTS start up. (See processing in s-inmaop.adb). Pass + -- the Interrupt_Mask of the environment task to the Interrupt_Manager. - -- Note : At this point we know that all tasks (including - -- RTS internal servers) are masked for non-reserved signals - -- (see s-taprop.adb). Only the Interrupt_Manager will have - -- masks set up differently inheriting the original environment - -- task's mask. + -- Note : At this point we know that all tasks are masked for non-reserved + -- signals. Only the Interrupt_Manager will have masks set up differently + -- inheriting the original environment task's mask. Interrupt_Manager.Initialize (IMOP.Environment_Mask); end System.Interrupts; diff --git a/gcc/ada/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb index 9ef33ab5a15..0f67306b31d 100644 --- a/gcc/ada/s-intman-dummy.adb +++ b/gcc/ada/s-intman-dummy.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -35,15 +35,4 @@ package body System.Interrupt_Management is - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-irix-athread.adb b/gcc/ada/s-intman-irix-athread.adb index 57771303f16..9a01480ef18 100644 --- a/gcc/ada/s-intman-irix-athread.adb +++ b/gcc/ada/s-intman-irix-athread.adb @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -82,28 +82,6 @@ package body System.Interrupt_Management is pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - ---------------------- - -- Notify_Exception -- - ---------------------- - - -- This function identifies the Ada exception to be raised using the - -- information when the system received a synchronous signal. - -- Since this function is machine and OS dependent, different code has to - -- be provided for different target. - -- On SGI, the signal handling is done is a-init.c, even when tasking is - -- involved. - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - begin declare function State (Int : Interrupt_ID) return Character; diff --git a/gcc/ada/s-intman-irix.adb b/gcc/ada/s-intman-irix.adb index 2a290e105da..346e89b9f5a 100644 --- a/gcc/ada/s-intman-irix.adb +++ b/gcc/ada/s-intman-irix.adb @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +--- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -59,17 +59,6 @@ package body System.Interrupt_Management is SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, SIGABRT, SIGPIPE); - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - Unreserve_All_Interrupts : Interfaces.C.int; pragma Import (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); diff --git a/gcc/ada/s-intman-mingw.adb b/gcc/ada/s-intman-mingw.adb index 362e50132ff..c7c40227b80 100644 --- a/gcc/ada/s-intman-mingw.adb +++ b/gcc/ada/s-intman-mingw.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -50,18 +50,6 @@ with System.OS_Interface; use System.OS_Interface; package body System.Interrupt_Management is - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - begin -- "Reserve" all the interrupts, except those that are explicitely defined diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb index d8d5963fca2..a4ee11f27a6 100644 --- a/gcc/ada/s-intman-solaris.adb +++ b/gcc/ada/s-intman-solaris.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 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- -- @@ -121,17 +121,6 @@ package body System.Interrupt_Management is end case; end Notify_Exception; - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - ---------------------------- -- Package Initialization -- ---------------------------- diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb index 1190378766f..4286eb06d37 100644 --- a/gcc/ada/s-intman-vms.adb +++ b/gcc/ada/s-intman-vms.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, 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- -- @@ -33,12 +33,6 @@ -- This is a OpenVMS/Alpha version of this package. --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. - --- See the other warnings in the package specification before making --- any modifications to this file. - with System.OS_Interface; -- used for various Constants, Signal and types @@ -47,13 +41,16 @@ package body System.Interrupt_Management is use System.OS_Interface; use type unsigned_long; - --------------------------- - -- Initialize_Interrupts -- - --------------------------- +begin + Abort_Task_Interrupt := Interrupt_ID_0; + -- Unused + + Reserve := Reserve or Keep_Unmasked or Keep_Masked; - procedure Initialize_Interrupts is - Status : Cond_Value_Type; + Reserve (Interrupt_ID_0) := True; + declare + Status : Cond_Value_Type; begin Sys_Crembx (Status => Status, @@ -73,16 +70,5 @@ package body System.Interrupt_Management is Flags => AGN_M_WRITEONLY); pragma Assert ((Status and 1) = 1); - end Initialize_Interrupts; - -begin - -- Unused - - Abort_Task_Interrupt := Interrupt_ID_0; - - Reserve := Reserve or Keep_Unmasked or Keep_Masked; - - Reserve (Interrupt_ID_0) := True; - - Initialize_Interrupts; + end; end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads index a74659ada4c..2444e9014a8 100644 --- a/gcc/ada/s-intman-vms.ads +++ b/gcc/ada/s-intman-vms.ads @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- @@ -110,12 +110,6 @@ package System.Interrupt_Management is -- example, if interrupts are OS signals and signal masking is per-task, -- use of the sigwait operation requires the signal be masked in all tasks. - procedure Initialize_Interrupts; - -- On systems where there is no signal inheritance between tasks (e.g - -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should - -- only be called by initialize in this package body. - private use type System.OS_Interface.unsigned_long; diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb index eae409b9195..395fa3a8cb1 100644 --- a/gcc/ada/s-intman-vxworks.adb +++ b/gcc/ada/s-intman-vxworks.adb @@ -1,12 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- -- 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- -- @@ -62,10 +62,8 @@ package body System.Interrupt_Management is Exception_Signals : constant Signal_List (1 .. 4) := (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - -- Keep these variables global so that they are initialized only once - -- What are "these variables" ???, I see only one - Exception_Action : aliased struct_sigaction; + -- Keep this variable global so that it is initialized only once procedure Map_And_Raise_Exception (signo : Signal); pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal"); @@ -108,7 +106,6 @@ package body System.Interrupt_Management is procedure Initialize_Interrupts is Result : int; old_act : aliased struct_sigaction; - begin for J in Exception_Signals'Range loop Result := diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index 7e386f300f4..1e4deedadf7 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- @@ -110,10 +110,9 @@ package System.Interrupt_Management is -- or used to implement time delays. procedure Initialize_Interrupts; - -- On systems where there is no signal inheritance between tasks (e.g - -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should only - -- be called by initialize in this package body. + -- Under VxWorks, there is no signal inheritance between tasks. + -- This procedure is used to initialize signal-to-exception mapping in + -- each task. private type Interrupt_Mask is new System.OS_Interface.sigset_t; diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads index c8d2a0e2d3c..9cb3296eb9e 100644 --- a/gcc/ada/s-intman.ads +++ b/gcc/ada/s-intman.ads @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- -- -- @@ -103,12 +103,6 @@ package System.Interrupt_Management is -- example, it may be mapped to an exception used to implement task abort, -- or used to implement time delays. - procedure Initialize_Interrupts; - -- On systems where there is no signal inheritance between tasks (e.g - -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should only - -- be called by initialize in this package body. - private type Interrupt_Mask is new System.OS_Interface.sigset_t; -- In some implementations Interrupt_Mask can be represented as a linked diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads index eec2e6ead98..6d75dd87f59 100644 --- a/gcc/ada/s-osinte-mingw.ads +++ b/gcc/ada/s-osinte-mingw.ads @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . O S _ I N T E R F A C E -- -- -- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -198,19 +198,22 @@ pragma Preelaborate; ----------------------- type CRITICAL_SECTION is private; - type PCRITICAL_SECTION is access all CRITICAL_SECTION; - procedure InitializeCriticalSection (pCriticalSection : PCRITICAL_SECTION); + procedure InitializeCriticalSection + (pCriticalSection : access CRITICAL_SECTION); pragma Import (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); - procedure EnterCriticalSection (pCriticalSection : PCRITICAL_SECTION); + procedure EnterCriticalSection + (pCriticalSection : access CRITICAL_SECTION); pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); - procedure LeaveCriticalSection (pCriticalSection : PCRITICAL_SECTION); + procedure LeaveCriticalSection + (pCriticalSection : access CRITICAL_SECTION); pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); - procedure DeleteCriticalSection (pCriticalSection : PCRITICAL_SECTION); + procedure DeleteCriticalSection + (pCriticalSection : access CRITICAL_SECTION); pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); ------------------------------------------------------------- diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb index 4bbc43509da..e65b85f6919 100644 --- a/gcc/ada/s-taasde.adb +++ b/gcc/ada/s-taasde.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 I N G . A S Y N C _ D E L A Y S -- -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -64,6 +64,9 @@ with System.OS_Primitives; with Ada.Task_Identification; -- used for Task_Id type +with System.Interrupt_Management.Operations; +-- used for Setup_Interrupt_Mask + with System.Parameters; -- used for Single_Lock -- Runtime_Traces @@ -324,6 +327,12 @@ package body System.Tasking.Async_Delays is begin Timer_Server_ID := STPO.Self; + -- Since this package may be elaborated before System.Interrupt, + -- we need to call Setup_Interrupt_Mask explicitly to ensure that + -- this task has the proper signal mask. + + Interrupt_Management.Operations.Setup_Interrupt_Mask; + -- Initialize the timer queue to empty, and make the wakeup time of the -- header node be larger than any real wakeup time we will ever use. diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index c6d4ba07c7c..651fc12269a 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.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- -- @@ -87,6 +87,15 @@ package body System.Task_Primitives.Operations is return True; end Check_No_Locks; + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + begin + return False; + end Current_State; + ---------------------- -- Environment_Task -- ---------------------- @@ -129,6 +138,15 @@ 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 -- ------------------- @@ -179,6 +197,11 @@ package body System.Task_Primitives.Operations is null; end Initialize; + procedure Initialize (S : in out Suspension_Object) is + begin + null; + end Initialize; + --------------------- -- Initialize_Lock -- --------------------- @@ -289,6 +312,15 @@ package body System.Task_Primitives.Operations is return Null_Task; end Self; + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + begin + null; + end Set_False; + ------------------ -- Set_Priority -- ------------------ @@ -302,6 +334,15 @@ package body System.Task_Primitives.Operations is null; end Set_Priority; + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + begin + null; + end Set_True; + ----------- -- Sleep -- ----------- @@ -332,6 +373,15 @@ package body System.Task_Primitives.Operations is return False; end Suspend_Task; + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + begin + null; + end Suspend_Until_True; + ----------------- -- Timed_Delay -- ----------------- diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index c5a13d03951..998b4afdc15 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.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- -- @@ -910,6 +910,156 @@ package body System.Task_Primitives.Operations is 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_mutex_init (S.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + -- Initialize internal condition variable + + 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 + 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 := 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 -- ---------------- diff --git a/gcc/ada/s-taprop-irix-athread.adb b/gcc/ada/s-taprop-irix-athread.adb index 78580ac5558..64c1f069ca1 100644 --- a/gcc/ada/s-taprop-irix-athread.adb +++ b/gcc/ada/s-taprop-irix-athread.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- -- @@ -819,6 +819,187 @@ package body System.Task_Primitives.Operations is 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 -- ---------------- diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 21b330182d5..e3b05b54f8f 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.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- -- @@ -57,11 +57,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 @@ -965,6 +960,187 @@ package body System.Task_Primitives.Operations is 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 -- ---------------- @@ -1078,7 +1254,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; @@ -1099,15 +1275,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); diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index e2aab2e2c0e..07a44dfc573 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -52,11 +52,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 @@ -81,7 +76,7 @@ with System.OS_Primitives; -- used for Delay_Modes with System.Soft_Links; --- used for Get_Machine_State_Addr +-- used for Abort_Defer/Undefer with Unchecked_Conversion; with Unchecked_Deallocation; @@ -933,6 +928,156 @@ package body System.Task_Primitives.Operations is end Abort_Task; ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + 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_mutex_init (S.L'Access, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + -- Initialize internal condition variable + + 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 + 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 := 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 -- ---------------- @@ -1054,15 +1199,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); 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); diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index d6a1a61ca9e..11a5b7a0a0b 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- @@ -1041,6 +1041,140 @@ package body System.Task_Primitives.Operations is 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, True, 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 = 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 + EnterCriticalSection (S.L'Access); + + S.State := False; + + LeaveCriticalSection (S.L'Access); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : BOOL; + begin + 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 = True); + else + S.State := True; + end if; + + LeaveCriticalSection (S.L'Access); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : DWORD; + Result_Bool : BOOL; + begin + 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); + + 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); + else + S.Waiting := True; + + -- Must reset CV BEFORE L is unlocked. + + Result_Bool := ResetEvent (S.CV); + pragma Assert (Result_Bool = True); + + LeaveCriticalSection (S.L'Access); + + Result := WaitForSingleObject (S.CV, Wait_Infinite); + pragma Assert (Result = 0); + end if; + end if; + end Suspend_Until_True; + + ---------------- -- Check_Exit -- ---------------- diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb index d922adedcf8..cd99f79b4a5 100644 --- a/gcc/ada/s-taprop-os2.adb +++ b/gcc/ada/s-taprop-os2.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- @@ -1013,6 +1013,148 @@ package body System.Task_Primitives.Operations is end Abort_Task; ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + 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 + if DosCreateMutexSem + (ICS.Null_Ptr, S.L'Unchecked_Access, 0, False32) /= NO_ERROR + then + raise Storage_Error; + end if; + + pragma Assert (S.L /= 0, "Error creating Mutex"); + + -- Initialize internal condition variable + + if DosCreateEventSem + (ICS.Null_Ptr, S.CV'Unchecked_Access, 0, True32) /= NO_ERROR + then + Must_Not_Fail (DosCloseMutexSem (S.L)); + + raise Storage_Error; + end if; + + pragma Assert (S.CV /= 0, "Error creating Condition Variable"); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + begin + -- Destroy internal mutex + + Must_Not_Fail (DosCloseMutexSem (S.L'Access)); + + -- Destroy internal condition variable + + Must_Not_Fail (DosCloseEventSem (S.CV'Access)); + 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 + Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); + + S.State := False; + + Must_Not_Fail (DosReleaseMutexSem (S.L)); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + begin + Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); + + -- 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; + + Sem_Must_Not_Fail (DosPostEventSem (S.CV)); + else + S.State := True; + end if; + + Must_Not_Fail (DosReleaseMutexSem (S.L)); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Count : aliased ULONG; -- Used to store dummy result + begin + Must_Not_Fail (DosRequestMutexSem (S.L, SEM_INDEFINITE_WAIT)); + + 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). + + Must_Not_Fail (DosReleaseMutexSem (S.L)); + + 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; + + Must_Not_Fail (DosReleaseMutexSem (S.L)); + else + S.Waiting := True; + + -- Must reset Cond BEFORE L is unlocked + + Sem_Must_Not_Fail + (DosResetEventSem (S.CV, Count'Unchecked_Access)); + + Must_Not_Fail (DosReleaseMutexSem (S.L)); + + Sem_Must_Not_Fail + (DosWaitEventSem (S.CV, SEM_INDEFINITE_WAIT)); + end if; + end if; + end Suspend_Until_True; + + ---------------- -- Check_Exit -- ---------------- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 4d8057dc3d2..268fa228612 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.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- -- @@ -61,11 +61,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 @@ -1037,13 +1032,193 @@ 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)); 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 -- ---------------- @@ -1181,13 +1356,6 @@ 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); diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 69db09f7e47..dda5779d932 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.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- -- @@ -58,11 +58,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 @@ -1060,8 +1055,6 @@ package body System.Task_Primitives.Operations is Result := thr_kill (T.Common.LL.Thread, Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - null; - pragma Assert (Result = 0); end Abort_Task; @@ -1632,6 +1625,154 @@ package body System.Task_Primitives.Operations is end Check_Finalize_Lock; ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + 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 := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Raise_Exception (Storage_Error'Identity, "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 + Result := mutex_lock (S.L'Access); + pragma Assert (Result = 0); + + S.State := False; + + Result := 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 := 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); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : Interfaces.C.int; + begin + 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 + -- (ARM D.10 par. 10). + + Result := 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 := cond_wait (S.CV'Access, S.L'Access); + end if; + end if; + + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + end Suspend_Until_True; + + ---------------- -- Check_Exit -- ---------------- @@ -1736,15 +1877,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); diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 9a0bba98c9c..89d4ca31413 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- @@ -58,11 +58,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 @@ -972,14 +967,177 @@ 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); + 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); + + 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 + 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 := 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 -- ---------------- @@ -1114,15 +1272,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); diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 41612d49e30..3a8eb723653 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.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- -- @@ -887,7 +887,7 @@ package body System.Task_Primitives.Operations is procedure Exit_Task is begin - Specific.Set (null); + null; end Exit_Task; ---------------- @@ -904,6 +904,187 @@ package body System.Task_Primitives.Operations is 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 -- ---------------- diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 4298e09e845..c2b56956e63 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -1,6 +1,6 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- @@ -1010,7 +1010,6 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : int; - begin Result := kill (T.Common.LL.Thread, Signal (Interrupt_Management.Abort_Task_Signal)); @@ -1018,6 +1017,148 @@ package body System.Task_Primitives.Operations is end Abort_Task; ---------------- + -- 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 + + -- 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 + 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 + Result := semTake (S.L, WAIT_FOREVER); + pragma Assert (Result = OK); + + S.State := False; + + Result := semGive (S.L); + pragma Assert (Result = OK); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + Result : STATUS; + begin + 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 ARM D.10 par. 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); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + Result : STATUS; + begin + 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 + -- (ARM D.10 par. 10). + + Result := semGive (S.L); + pragma Assert (Result = OK); + + 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; + + Result := semGive (S.L); + pragma Assert (Result = 0); + else + S.Waiting := True; + + -- Release the mutex before sleeping + + Result := semGive (S.L); + pragma Assert (Result = OK); + + 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/s-taprop.ads b/gcc/ada/s-taprop.ads index e3c80baf71b..79c55c024de 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -444,6 +444,38 @@ 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 -- ----------------------------------------- diff --git a/gcc/ada/s-taspri-dummy.ads b/gcc/ada/s-taspri-dummy.ads index 6e6025c589d..23a1aff6408 100644 --- a/gcc/ada/s-taspri-dummy.ads +++ b/gcc/ada/s-taspri-dummy.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -44,12 +44,14 @@ package System.Task_Primitives is type RTS_Lock is new Integer; + type Suspension_Object is new Integer; + type Task_Body_Access is access procedure; type Private_Data is record - Thread : aliased Integer; - CV : aliased Integer; - L : aliased RTS_Lock; + Thread : aliased Integer; + CV : aliased Integer; + L : aliased RTS_Lock; end record; end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-hpux-dce.ads b/gcc/ada/s-taspri-hpux-dce.ads index 4f422c24271..9f34bfea134 100644 --- a/gcc/ada/s-taspri-hpux-dce.ads +++ b/gcc/ada/s-taspri-hpux-dce.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -31,9 +31,9 @@ -- -- ------------------------------------------------------------------------------ --- This is a HP-UX version of this package. +-- This is a HP-UX version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -47,22 +47,24 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private type Lock is record @@ -72,18 +74,37 @@ private end record; type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + 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.pthread_mutex_t; + -- 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 record - Thread : aliased System.OS_Interface.pthread_t; + Thread : aliased System.OS_Interface.pthread_t; 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. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L + -- (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. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L end record; end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-linux.ads b/gcc/ada/s-taspri-linux.ads index 078ef3e0e8a..d91738a9990 100644 --- a/gcc/ada/s-taspri-linux.ads +++ b/gcc/ada/s-taspri-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -31,9 +31,9 @@ -- -- ------------------------------------------------------------------------------ --- This is the GNU/Linux (GNU/LinuxThreads) version of this package. +-- This is the GNU/Linux (GNU/LinuxThreads) version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -47,34 +47,55 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private type Prio_Array_Type is array (System.Any_Priority) of Integer; type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : System.Any_Priority := System.Any_Priority'First; + L : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority := System.Any_Priority'First; Saved_Priority : System.Any_Priority := System.Any_Priority'First; end record; type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + 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.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until the condition is + -- signaled. + end record; + type Private_Data is record Thread : aliased System.OS_Interface.pthread_t; pragma Atomic (Thread); @@ -84,13 +105,14 @@ private -- use lock on those operations and the only thing we have to -- make sure is that they are updated in atomic fashion. - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L Active_Priority : System.Any_Priority := System.Any_Priority'First; - -- Simulated active priority, - -- used only if Priority_Ceiling_Support is True. + -- Simulated active priority, used only if Priority_Ceiling_Support + -- is True. end record; end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-lynxos.ads b/gcc/ada/s-taspri-lynxos.ads index bf079fd34a3..ce8c0ca17d4 100644 --- a/gcc/ada/s-taspri-lynxos.ads +++ b/gcc/ada/s-taspri-lynxos.ads @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -32,8 +32,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a LynxOS version of this package, derived from --- 7staspri.ads +-- This is a LynxOS version of this package, derived from 7staspri.ads pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -47,22 +46,24 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private @@ -74,14 +75,31 @@ private type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + 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.pthread_mutex_t; + -- 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 record Thread : aliased System.OS_Interface.pthread_t; 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. + -- (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. LWP : aliased System.Address; -- The purpose of this field is to provide a better tasking support on @@ -90,7 +108,7 @@ private CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; + L : aliased RTS_Lock; -- Protection for all components is lock L end record; diff --git a/gcc/ada/s-taspri-mingw.ads b/gcc/ada/s-taspri-mingw.ads index 01cde2c6910..0e1707fc880 100644 --- a/gcc/ada/s-taspri-mingw.ads +++ b/gcc/ada/s-taspri-mingw.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a NT (native) version of this package. +-- This is a NT (native) version of this package pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -45,22 +45,24 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private @@ -74,6 +76,23 @@ private type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; + 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.CRITICAL_SECTION; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.HANDLE; + -- Condition variable used to queue threads until condition is signaled + end record; + type Private_Data is record Thread : aliased System.OS_Interface.HANDLE; pragma Atomic (Thread); @@ -84,8 +103,7 @@ private -- make sure is that they are updated in atomic fashion. Thread_Id : aliased System.OS_Interface.DWORD; - -- The purpose of this field is to provide a better tasking support - -- in gdb. + -- Used to provide a better tasking support in gdb CV : aliased Condition_Variable; -- Condition Variable used to implement Sleep/Wakeup diff --git a/gcc/ada/s-taspri-os2.ads b/gcc/ada/s-taspri-os2.ads index cb5b0295b13..e434ac53802 100644 --- a/gcc/ada/s-taspri-os2.ads +++ b/gcc/ada/s-taspri-os2.ads @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -32,9 +32,9 @@ -- -- ------------------------------------------------------------------------------ --- This is an OS/2 version of this package. +-- This is an OS/2 version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -47,6 +47,8 @@ package System.Task_Primitives is pragma Preelaborate; + -- Why are these commented out ??? + -- type Lock is limited private; -- Should be used for implementation of protected objects. @@ -65,7 +67,7 @@ package System.Task_Primitives is -- basis. A component of this type is guaranteed to be included -- in the Ada_Task_Control_Block. --- private +-- private (why commented out???) type Lock is record Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX; @@ -76,14 +78,31 @@ package System.Task_Primitives is type RTS_Lock is new 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 Interfaces.OS2Lib.Synchronization.HMTX; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased Interfaces.OS2Lib.Synchronization.HEV; + -- Condition variable used to queue threads until condition is signaled + end record; + type Private_Data is record - Thread : aliased Interfaces.OS2Lib.Threads.TID; + Thread : aliased Interfaces.OS2Lib.Threads.TID; 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. + -- (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. CV : aliased Interfaces.OS2Lib.Synchronization.HEV; @@ -91,17 +110,16 @@ package System.Task_Primitives is -- Protection for all components is lock L Current_Priority : Integer := -1; - -- The Current_Priority is the actual priority of a thread. - -- This field is needed because it is only possible to set a - -- delta priority in OS/2. The only places where this field should - -- be set are Set_Priority, Create_Task and Initialize (Environment). + -- The Current_Priority is the actual priority of a thread. This field + -- is needed because it is only possible to set delta priority in OS/2. + -- The only places where this field should be set are Set_Priority, + -- Create_Task and Initialize (Environment). Wrapper : Interfaces.OS2Lib.Threads.PFNTHREAD; - -- This is the original wrapper passed by Operations.Create_Task. - -- When installing an exception handler in a thread, the thread - -- starts executing the Exception_Wrapper which calls Wrapper - -- when the handler has been installed. The handler is removed when - -- wrapper returns. + -- This is the original wrapper passed by Operations.Create_Task. When + -- installing an exception handler in a thread, the thread starts + -- executing the Exception_Wrapper which calls Wrapper when the handler + -- has been installed. The handler is removed when wrapper returns. end record; end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads index 1717cce47f5..3e31f7e46cf 100644 --- a/gcc/ada/s-taspri-posix.ads +++ b/gcc/ada/s-taspri-posix.ads @@ -1,13 +1,13 @@ ------------------------------------------------------------------------------ -- -- --- 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 -- -- -- -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2003, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -32,8 +32,9 @@ -- -- ------------------------------------------------------------------------------ --- This is a POSIX-like version of this package. --- Note: this file can only be used for POSIX compliant systems. +-- This is a POSIX-like version of this package + +-- Note: this file can only be used for POSIX compliant systems pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -47,36 +48,55 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). + -- Pointer to the task body's entry point (or possibly a wrapper declared + -- local to the GNARL). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private type Lock is new System.OS_Interface.pthread_mutex_t; type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + 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.pthread_mutex_t; + -- 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 record Thread : aliased System.OS_Interface.pthread_t; 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. + -- (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. LWP : aliased System.Address; -- The purpose of this field is to provide a better tasking support on @@ -84,8 +104,9 @@ private -- On targets where lwp is not relevant, this is equivalent to Thread. CV : aliased System.OS_Interface.pthread_cond_t; + -- Should be commented ??? (in all versions of taspri) - L : aliased RTS_Lock; + L : aliased RTS_Lock; -- Protection for all components is lock L end record; diff --git a/gcc/ada/s-taspri-solaris.ads b/gcc/ada/s-taspri-solaris.ads index 335079b7cec..668cd837ca4 100644 --- a/gcc/ada/s-taspri-solaris.ads +++ b/gcc/ada/s-taspri-solaris.ads @@ -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 -- -- -- -- S p e c -- -- -- --- 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- -- @@ -33,7 +33,7 @@ -- This is a Solaris version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -55,26 +55,28 @@ package System.Task_Primitives is type RTS_Lock is limited private; type RTS_Lock_Ptr is access all RTS_Lock; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. function To_Lock_Ptr is new Unchecked_Conversion (RTS_Lock_Ptr, 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private type Private_Task_Serial_Number is mod 2 ** 64; - -- Used to give each task a unique serial number. + -- Used to give each task a unique serial number type Base_Lock is new System.OS_Interface.mutex_t; @@ -99,28 +101,44 @@ private type RTS_Lock is new Lock; - -- Note that task support on gdb relies on the fact that the first - -- 2 fields of Private_Data are Thread and LWP. + 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. type Private_Data is record - Thread : aliased System.OS_Interface.thread_t; + Thread : aliased System.OS_Interface.thread_t; 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. + -- (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. LWP : System.OS_Interface.lwpid_t; - -- The LWP id of the thread. Set by self in Enter_Task. + -- The LWP id of the thread. Set by self in Enter_Task CV : aliased System.OS_Interface.cond_t; L : aliased RTS_Lock; -- Protection for all components is lock L Active_Priority : System.Any_Priority := System.Any_Priority'First; - -- Simulated active priority, - -- used only if Priority_Ceiling_Support is True. + -- Simulated active priority, used iff Priority_Ceiling_Support is True Locking : Lock_Ptr; Locks : Lock_Ptr; diff --git a/gcc/ada/s-taspri-tru64.ads b/gcc/ada/s-taspri-tru64.ads index 2caf54b5f25..e524d573fb8 100644 --- a/gcc/ada/s-taspri-tru64.ads +++ b/gcc/ada/s-taspri-tru64.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -31,9 +31,9 @@ -- -- ------------------------------------------------------------------------------ --- This is the DEC Unix 4.0 version of this package. +-- This is the DEC Unix 4.0 version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -51,43 +51,63 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included private type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : Interfaces.C.int; + L : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : Interfaces.C.int; end record; type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + 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.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until the is signaled + end record; + type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; + Thread : aliased System.OS_Interface.pthread_t; 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. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L + -- (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. + + CV : aliased System.OS_Interface.pthread_cond_t; + + L : aliased RTS_Lock; + -- Protection for all components is lock L end record; end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads index 09179325c81..35c22dce793 100644 --- a/gcc/ada/s-taspri-vms.ads +++ b/gcc/ada/s-taspri-vms.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2000 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -31,9 +31,9 @@ -- -- ------------------------------------------------------------------------------ --- This is a OpenVMS/Alpha version of this package. +-- This is a OpenVMS/Alpha version of this package --- This package provides low-level support for most tasking features. +-- This package provides low-level support for most tasking features pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -51,22 +51,24 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private @@ -81,21 +83,40 @@ private end record; type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + 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.pthread_mutex_t; + -- Protection for ensuring mutual exclusion on the Suspension_Object + + CV : aliased System.OS_Interface.pthread_cond_t; + -- Condition variable used to queue threads until ondition is signaled + end record; + type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; + Thread : aliased System.OS_Interface.pthread_t; 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. + -- (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. + + CV : aliased System.OS_Interface.pthread_cond_t; - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L + L : aliased RTS_Lock; + -- Protection for all components is lock L Exc_Stack_Ptr : Exc_Stack_Ptr_T; - -- ??? This needs comments. + -- ??? This needs comments AST_Pending : Boolean; -- Used to detect delay and sleep timeouts diff --git a/gcc/ada/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads index efd41ccd984..2f3be4cdc2f 100644 --- a/gcc/ada/s-taspri-vxworks.ads +++ b/gcc/ada/s-taspri-vxworks.ads @@ -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 -- -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a VxWorks version of this package. +-- This is a VxWorks version of this package pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during @@ -42,36 +42,56 @@ with System.OS_Interface; package System.Task_Primitives is type Lock is limited private; - -- Should be used for implementation of protected objects. + -- Should be used for implementation of protected objects type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. + -- Should be used inside the runtime system. The difference between Lock + -- and the RTS_Lock is that the later one serves only as a semaphore so + -- that do not check for ceiling violations. + + 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). type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. + -- Any information that the GNULLI needs maintained on a per-task basis. + -- A component of this type is guaranteed to be included in the + -- Ada_Task_Control_Block. private type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit); type Lock is record - Mutex : System.OS_Interface.SEM_ID; - Protocol : Priority_Type; + Mutex : System.OS_Interface.SEM_ID; + Protocol : Priority_Type; + Prio_Ceiling : System.OS_Interface.int; - -- priority ceiling of lock + -- Priority ceiling of lock end record; type RTS_Lock is new 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 record Thread : aliased System.OS_Interface.t_id := 0; pragma Atomic (Thread); |