+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
+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 --
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;
---------------
procedure Set_False (S : in out Suspension_Object) is
begin
- S.Set_False;
+ System.Task_Primitives.Operations.Set_False (S.SO);
end Set_False;
--------------
procedure Set_True (S : in out Suspension_Object) is
begin
- S.Set_True;
+ System.Task_Primitives.Operations.Set_True (S.SO);
end Set_True;
------------------------
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;
-- --
-- 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 --
-- --
------------------------------------------------------------------------------
-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;
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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
null;
end Interrupt_Self_Process;
+ --------------------------
+ -- Setup_Interrupt_Mask --
+ --------------------------
+
+ procedure Setup_Interrupt_Mask is
+ begin
+ null;
+ end Setup_Interrupt_Mask;
+
end System.Interrupt_Management.Operations;
------------------------------------------------------------------------------
-- --
--- 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- --
is
Result : Interfaces.C.int;
Mask : aliased sigset_t;
-
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
is
Mask : aliased sigset_t;
Result : Interfaces.C.int;
-
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
-
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
OMask : access Interrupt_Mask)
is
Result : Interfaces.C.int;
-
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
-
begin
Result := pthread_sigmask
(SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
is
Result : Interfaces.C.int;
Sig : aliased Signal;
-
begin
Result := sigwait (Mask, Sig'Access);
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
Result : Interfaces.C.int;
-
begin
Result := sigaction
(Signal (Interrupt),
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);
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
-
begin
Result := sigfillset (Mask);
pragma Assert (Result = 0);
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
-
begin
Result := sigemptyset (Mask);
pragma Assert (Result = 0);
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
-
begin
Result := sigaddset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
-
begin
Result := sigdelset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
Interrupt : Interrupt_ID) return Boolean
is
Result : Interfaces.C.int;
-
begin
Result := sigismember (Mask, Signal (Interrupt));
pragma Assert (Result = 0 or else Result = 1);
procedure Copy_Interrupt_Mask
(X : out Interrupt_Mask;
- Y : Interrupt_Mask)
- is
+ Y : Interrupt_Mask) is
begin
X := Y;
end Copy_Interrupt_Mask;
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
------------------------------------------------------------------------------
-- --
--- 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- --
X := Y;
end Copy_Interrupt_Mask;
- -------------------------
+ ----------------------------
-- Interrupt_Self_Process --
- -------------------------
+ ----------------------------
procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
Status : Cond_Value_Type;
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);
------------------------------------------------------------------------------
-- --
--- 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- --
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
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
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;
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
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;
------------------------------------------------------------------------------
-- --
--- 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- --
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;
------------------------------------------------------------------------------
-- --
--- 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- --
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");
------------------------------------------------------------------------------
-- --
--- 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- --
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
------------------------------------------------------------------------------
-- --
--- 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- --
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 --
----------------------------
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
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,
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;
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
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");
procedure Initialize_Interrupts is
Result : int;
old_act : aliased struct_sigaction;
-
begin
for J in Exception_Signals'Range loop
Result :=
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
-- 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;
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
-- 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
------------------------------------------------------------------------------
-- --
--- 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- --
-----------------------
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");
-------------------------------------------------------------
------------------------------------------------------------------------------
-- --
--- 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- --
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
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.
------------------------------------------------------------------------------
-- --
--- 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- --
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 --
----------------------
null;
end Exit_Task;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Finalize;
+
-------------------
-- Finalize_Lock --
-------------------
null;
end Initialize;
+ procedure Initialize (S : in out Suspension_Object) is
+ begin
+ null;
+ end Initialize;
+
---------------------
-- Initialize_Lock --
---------------------
return Null_Task;
end Self;
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_False;
+
------------------
-- Set_Priority --
------------------
null;
end Set_Priority;
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ begin
+ null;
+ end Set_True;
+
-----------
-- Sleep --
-----------
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 --
-----------------
------------------------------------------------------------------------------
-- --
--- 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- --
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 --
----------------
------------------------------------------------------------------------------
-- --
--- 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- --
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 --
----------------
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
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 --
----------------
-- 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;
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);
-- --
-- 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- --
-- 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
-- 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;
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 --
----------------
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);
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task.
+ -- A variable to hold Task_Id for the environment task
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
- -- The followings are internal configuration constants needed.
+ -- The followings are internal configuration constants needed
Next_Serial_Number : Task_Serial_Number := 100;
-- We start at 100, to reserve some special values for
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
- -- Indicates whether FIFO_Within_Priorities is set.
+ -- Indicates whether FIFO_Within_Priorities is set
Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads).
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
- -- Initialize various data needed by this package.
+ -- Initialize various data needed by this package
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
- -- Set the self id for the current task.
+ -- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task.
+ -- Return a pointer to the Ada Task Control Block of the calling task
end Specific;
package body Specific is separate;
- -- The body of this package is target specific.
+ -- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread.
+ -- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
procedure Abort_Handler (Sig : Signal);
- -- Signal handler used to implement asynchronous abort.
+ -- Signal handler used to implement asynchronous abort
procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority);
-- This procedure calls the scheduler of the OS to set thread's priority
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result :=
- pthread_kill
- (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result := pthread_kill (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Initialize internal state. It is always initialized to False (ARM
+ -- D.10 par. 6).
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+
+ -- Initialize internal condition variable
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ raise Storage_Error;
+ end if;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- If there is already a task waiting on this suspension object then
+ -- we resume it, leaving the state of the suspension object to False,
+ -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- the state to True.
+
+ if S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutex_lock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if S.Waiting then
+ -- Program_Error must be raised upon calling Suspend_Until_True
+ -- if another task is already waiting on that suspension object
+ -- (ARM D.10 par. 10).
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ raise Program_Error;
+ else
+ -- Suspend the task if the state is False. Otherwise, the task
+ -- continues its execution, and the state of the suspension object
+ -- is set to False (ARM D.10 par. 9).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ end if;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+ end Suspend_Until_True;
+
+ ----------------
-- Check_Exit --
----------------
begin
Environment_Task_Id := Environment_Task;
- -- Initialize the lock used to synchronize chain of all ATCBs.
+ -- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- 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;
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);
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
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 --
----------------
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
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 --
----------------
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
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 --
----------------
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);
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
Result := thr_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- null;
-
pragma Assert (Result = 0);
end Abort_Task;
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 --
----------------
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);
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
-- 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
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 --
----------------
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);
------------------------------------------------------------------------------
-- --
--- 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- --
procedure Exit_Task is
begin
- Specific.Set (null);
+ null;
end Exit_Task;
----------------
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 --
----------------
------------------------------------------------------------------------------
-- --
--- 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 --
-- --
procedure Abort_Task (T : Task_Id) is
Result : int;
-
begin
Result := kill (T.Common.LL.Thread,
Signal (Interrupt_Management.Abort_Task_Signal));
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 --
----------------
-- 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 --
-----------------------------------------
------------------------------------------------------------------------------
-- --
--- 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- --
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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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
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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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);
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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 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
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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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 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);
-- 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
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
pragma Preelaborate;
+ -- Why are these commented out ???
+
-- type Lock is limited private;
-- Should be used for implementation of protected objects.
-- 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;
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;
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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
-- 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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- 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
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;
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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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;
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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
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
------------------------------------------------------------------------------
-- --
--- 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- --
-- --
------------------------------------------------------------------------------
--- 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
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);
OSDN Git Service
