Skip to content

R
riscv-gcc-1
Commit b497b460 by Jose Ruiz Committed by Arnaud Charlet
Options

a-sytaco.ads, [...] (Suspension_Object): These objects are no longer protected objects. 

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

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

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

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

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

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

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

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

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

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

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

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

From-SVN: r101015
parent 3084fecd
Showing with 2452 additions and 747 deletions
gcc/ada/a-sytaco-vxworks.adb deleted 100644 → 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;
gcc/ada/a-sytaco-vxworks.ads deleted 100644 → 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;
gcc/ada/a-sytaco.adb
------------------------------------------------------------------------------
-- --
-- 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;
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;
gcc/ada/s-inmaop-dummy.adb
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-inmaop-posix.adb
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-inmaop-vms.adb
------------------------------------------------------------------------------
-- --
-- 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);
......
gcc/ada/s-inmaop.ads
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-interr.adb
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-intman-dummy.adb
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-intman-irix-athread.adb
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-intman-irix.adb
------------------------------------------------------------------------------
-- --
-- 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");
......
gcc/ada/s-intman-mingw.adb
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-intman-solaris.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------------------
......
gcc/ada/s-intman-vms.adb
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-intman-vms.ads
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-intman-vxworks.adb
------------------------------------------------------------------------------
-- --
-- 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 :=
......
gcc/ada/s-intman-vxworks.ads
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-intman.ads
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-osinte-mingw.ads
------------------------------------------------------------------------------
-- --
-- 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");
-------------------------------------------------------------
......
gcc/ada/s-taasde.adb
------------------------------------------------------------------------------
-- --
-- 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.
......
gcc/ada/s-taprop-dummy.adb
------------------------------------------------------------------------------
-- --
-- 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 --
-----------------
......
gcc/ada/s-taprop-hpux-dce.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
gcc/ada/s-taprop-irix-athread.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
gcc/ada/s-taprop-irix.adb
------------------------------------------------------------------------------
-- --
-- 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);
......
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);
......
gcc/ada/s-taprop-mingw.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
gcc/ada/s-taprop-os2.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
gcc/ada/s-taprop-posix.adb
------------------------------------------------------------------------------
-- --
-- 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);
......
gcc/ada/s-taprop-solaris.adb
------------------------------------------------------------------------------
-- --
-- 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);
......
gcc/ada/s-taprop-tru64.adb
------------------------------------------------------------------------------
-- --
-- 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);
......
gcc/ada/s-taprop-vms.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
gcc/ada/s-taprop-vxworks.adb
------------------------------------------------------------------------------
-- --
-- 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 --
----------------
......
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 --
-----------------------------------------
......
gcc/ada/s-taspri-dummy.ads
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-taspri-hpux-dce.ads
------------------------------------------------------------------------------
-- --
-- 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;
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;
gcc/ada/s-taspri-lynxos.ads
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-taspri-mingw.ads
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-taspri-os2.ads
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-taspri-posix.ads
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-taspri-solaris.ads
------------------------------------------------------------------------------
-- --
-- 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;
......
gcc/ada/s-taspri-tru64.ads
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-taspri-vms.ads
------------------------------------------------------------------------------
-- --
-- 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
......
gcc/ada/s-taspri-vxworks.ads
------------------------------------------------------------------------------
-- --
-- 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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment