diff options
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); |
