------------------------------------------------------------------------------
-- --
--- 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-2008, 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- --
-- 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 GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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 is a NT (native) version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.Tasking.Debug;
--- used for Known_Tasks
+with Ada.Unchecked_Deallocation;
with Interfaces.C;
--- used for int
--- size_t
-
with Interfaces.C.Strings;
--- used for Null_Ptr
-
-with System.OS_Interface;
--- used for various type, constant, and operations
-
-with System.Parameters;
--- used for Size_Type
-
-with System.Tasking;
--- used for Ada_Task_Control_Block
--- Task_Id
-
-with System.Soft_Links;
--- used for Defer/Undefer_Abort
--- to initialize TSD for a C thread, in function Self
-
--- Note that we do not use System.Tasking.Initialization directly since
--- this is a higher level package that we shouldn't depend on. For example
--- when using the restricted run time, it is replaced by
--- System.Tasking.Restricted.Initialization
+with System.Tasking.Debug;
with System.OS_Primitives;
--- used for Delay_Modes
-
with System.Task_Info;
--- used for Unspecified_Task_Info
+with System.Interrupt_Management;
+with System.Win32.Ext;
-with Unchecked_Deallocation;
+with System.Soft_Links;
+-- We use System.Soft_Links instead of System.Tasking.Initialization because
+-- the later is a higher level package that we shouldn't depend on. For
+-- example when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Stages.
package body System.Task_Primitives.Operations is
+ package SSL renames System.Soft_Links;
+
use System.Tasking.Debug;
use System.Tasking;
use Interfaces.C;
use System.OS_Interface;
use System.Parameters;
use System.OS_Primitives;
+ use System.Task_Info;
+ use System.Win32;
+ use System.Win32.Ext;
- pragma Link_With ("-Xlinker --stack=0x800000,0x1000");
- -- Change the stack size (8 MB) for tasking programs on Windows. This
- -- permit to have more than 30 tasks running at the same time. Note that
+ pragma Link_With ("-Xlinker --stack=0x200000,0x1000");
+ -- Change the default stack size (2 MB) for tasking programs on Windows.
+ -- This allows about 1000 tasks running at the same time. Note that
-- we set the stack size for non tasking programs on System unit.
+ -- Also note that under Windows XP, we use a Windows XP extension to
+ -- specify the stack size on a per task basis, as done under other OSes.
- package SSL renames System.Soft_Links;
+ ---------------------
+ -- Local Functions --
+ ---------------------
+
+ procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure InitializeCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import
+ (Stdcall, InitializeCriticalSection, "InitializeCriticalSection");
+
+ procedure EnterCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure EnterCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection");
+
+ procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection");
+
+ procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock);
+ procedure DeleteCriticalSection
+ (pCriticalSection : access CRITICAL_SECTION);
+ pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection");
----------------
-- Local Data --
----------------
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
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
- -- Indicates whether FIFO_Within_Priorities is set.
+ function Get_Policy (Prio : System.Any_Priority) return Character;
+ pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
+ -- Get priority specific dispatching policy
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)
+
+ Annex_D : Boolean := False;
+ -- Set to True if running with Annex-D semantics
------------------------------------
-- The thread local storage index --
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
end Specific;
Succeeded : BOOL;
begin
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end Set;
end Specific;
---------------------------------
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;
-- Condition Variable Functions --
----------------------------------
- procedure Initialize_Cond (Cond : access Condition_Variable);
+ procedure Initialize_Cond (Cond : not null access Condition_Variable);
-- Initialize given condition variable Cond
- procedure Finalize_Cond (Cond : access Condition_Variable);
- -- Finalize given condition variable Cond.
+ procedure Finalize_Cond (Cond : not null access Condition_Variable);
+ -- Finalize given condition variable Cond
- procedure Cond_Signal (Cond : access Condition_Variable);
+ procedure Cond_Signal (Cond : not null access Condition_Variable);
-- Signal condition variable Cond
procedure Cond_Wait
- (Cond : access Condition_Variable;
- L : access RTS_Lock);
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock);
-- Wait on conditional variable Cond, using lock L
procedure Cond_Timed_Wait
- (Cond : access Condition_Variable;
- L : access RTS_Lock;
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
Rel_Time : Duration;
Timed_Out : out Boolean;
Status : out Integer);
-- Initialize_Cond --
---------------------
- procedure Initialize_Cond (Cond : access Condition_Variable) is
+ procedure Initialize_Cond (Cond : not null access Condition_Variable) is
hEvent : HANDLE;
-
begin
- hEvent := CreateEvent (null, True, False, Null_Ptr);
+ hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (hEvent /= 0);
Cond.all := Condition_Variable (hEvent);
end Initialize_Cond;
-- No such problem here, DosCloseEventSem has been derived.
-- What does such refer to in above comment???
- procedure Finalize_Cond (Cond : access Condition_Variable) is
+ procedure Finalize_Cond (Cond : not null access Condition_Variable) is
Result : BOOL;
begin
Result := CloseHandle (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize_Cond;
-----------------
-- Cond_Signal --
-----------------
- procedure Cond_Signal (Cond : access Condition_Variable) is
+ procedure Cond_Signal (Cond : not null access Condition_Variable) is
Result : BOOL;
begin
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Cond_Signal;
---------------
-- Cond_Wait --
---------------
- -- Pre-assertion: Cond is posted
+ -- Pre-condition: Cond is posted
-- L is locked.
- -- Post-assertion: Cond is posted
+ -- Post-condition: Cond is posted
-- L is locked.
procedure Cond_Wait
- (Cond : access Condition_Variable;
- L : access RTS_Lock)
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock)
is
Result : DWORD;
Result_Bool : BOOL;
begin
- -- Must reset Cond BEFORE L is unlocked.
+ -- Must reset Cond BEFORE L is unlocked
Result_Bool := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result_Bool = True);
- Unlock (L);
+ pragma Assert (Result_Bool = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
pragma Assert (Result = 0);
- Write_Lock (L);
+ Write_Lock (L, Global_Lock => True);
end Cond_Wait;
---------------------
-- Cond_Timed_Wait --
---------------------
- -- Pre-assertion: Cond is posted
+ -- Pre-condition: Cond is posted
-- L is locked.
- -- Post-assertion: Cond is posted
+ -- Post-condition: Cond is posted
-- L is locked.
procedure Cond_Timed_Wait
- (Cond : access Condition_Variable;
- L : access RTS_Lock;
+ (Cond : not null access Condition_Variable;
+ L : not null access RTS_Lock;
Rel_Time : Duration;
Timed_Out : out Boolean;
Status : out Integer)
is
Time_Out_Max : constant DWORD := 16#FFFF0000#;
- -- NT 4 cannot handle timeout values that are too large,
- -- e.g. DWORD'Last - 1
+ -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
begin
- -- Must reset Cond BEFORE L is unlocked.
+ -- Must reset Cond BEFORE L is unlocked
Result := ResetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
- Unlock (L);
+ pragma Assert (Result = Win32.TRUE);
+ Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
end if;
end if;
- Write_Lock (L);
+ Write_Lock (L, Global_Lock => True);
-- Ensure post-condition
if Timed_Out then
Result := SetEvent (HANDLE (Cond.all));
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end if;
Status := Integer (Wait_Result);
-- Stack_Guard --
------------------
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, On);
-
+ pragma Unreferenced (T, On);
begin
null;
end Stack_Guard;
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Intialize_TCB and the Storage_Error is handled.
- -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
- -- the RTS is initialized before any status change of RTS.
- -- Therefore raising Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
- L : access Lock)
+ L : not null access Lock)
is
begin
InitializeCriticalSection (L.Mutex'Access);
L.Priority := Prio;
end Initialize_Lock;
- procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ procedure Initialize_Lock
+ (L : not null access RTS_Lock; Level : Lock_Level)
+ is
pragma Unreferenced (Level);
begin
- InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ InitializeCriticalSection (L);
end Initialize_Lock;
-------------------
-- Finalize_Lock --
-------------------
- procedure Finalize_Lock (L : access Lock) is
+ procedure Finalize_Lock (L : not null access Lock) is
begin
DeleteCriticalSection (L.Mutex'Access);
end Finalize_Lock;
- procedure Finalize_Lock (L : access RTS_Lock) is
+ procedure Finalize_Lock (L : not null access RTS_Lock) is
begin
- DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ DeleteCriticalSection (L);
end Finalize_Lock;
----------------
-- Write_Lock --
----------------
- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ procedure Write_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
begin
L.Owner_Priority := Get_Priority (Self);
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock;
+ (L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
begin
if not Single_Lock or else Global_Lock then
- EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ EnterCriticalSection (L);
end if;
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
- EnterCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ EnterCriticalSection (T.Common.LL.L'Access);
end if;
end Write_Lock;
-- Read_Lock --
---------------
- procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ procedure Read_Lock
+ (L : not null access Lock; Ceiling_Violation : out Boolean) is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
-- Unlock --
------------
- procedure Unlock (L : access Lock) is
+ procedure Unlock (L : not null access Lock) is
begin
LeaveCriticalSection (L.Mutex'Access);
end Unlock;
- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
+ procedure Unlock
+ (L : not null access RTS_Lock; Global_Lock : Boolean := False) is
begin
if not Single_Lock or else Global_Lock then
- LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
+ LeaveCriticalSection (L);
end if;
end Unlock;
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
- LeaveCriticalSection
- (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
+ LeaveCriticalSection (T.Common.LL.L'Access);
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
-- Timed_Sleep --
-----------------
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
+ -- This is for use within the run-time system, so abort is assumed to be
+ -- already deferred, and the caller should be holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_Id;
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Result : Integer;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
Local_Timedout : Boolean;
if Rel_Time > 0.0 then
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Local_Timedout, Result);
else
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Local_Timedout, Result);
end if;
Check_Time := Monotonic_Clock;
-----------------
procedure Timed_Delay
- (Self_ID : Task_Id;
- Time : Duration;
- Mode : ST.Delay_Modes)
+ (Self_ID : Task_Id;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
is
Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
- Result : Integer;
- Timedout : Boolean;
-
- begin
- -- Only the little window between deferring abort and
- -- locking Self_ID is the reason we need to
- -- check for pending abort and priority change below!
- SSL.Abort_Defer.all;
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
+ begin
if Single_Lock then
Lock_RTS;
end if;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Timedout, Result);
else
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Timedout, Result);
end if;
Check_Time := Monotonic_Clock;
end if;
Yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
------------
procedure Yield (Do_Yield : Boolean := True) is
begin
if Do_Yield then
- Sleep (0);
+ SwitchToThread;
+
+ elsif Annex_D then
+ -- If running with Annex-D semantics we need a delay
+ -- above 0 milliseconds here otherwise processes give
+ -- enough time to the other tasks to have a chance to
+ -- run.
+ --
+ -- This makes cxd8002 ACATS pass on Windows.
+
+ Sleep (1);
end if;
end Yield;
begin
Res := SetThreadPriority
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
- pragma Assert (Res = True);
+ pragma Assert (Res = Win32.TRUE);
- if FIFO_Within_Priorities then
+ if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
-- There were two paths were we needed to call Enter_Task :
-- 1) from System.Task_Primitives.Operations.Initialize
-- 2) from System.Tasking.Stages.Task_Wrapper
- --
- -- The thread initialisation has to be done only for the first case.
- --
- -- This is because the GetCurrentThread NT call does not return the
- -- real thread handler but only a "pseudo" one. It is not possible to
- -- release the thread handle and free the system ressources from this
- -- "pseudo" handle. So we really want to keep the real thread handle
- -- set in System.Task_Primitives.Operations.Create_Task during the
- -- thread creation.
+
+ -- The thread initialisation has to be done only for the first case
+
+ -- This is because the GetCurrentThread NT call does not return the real
+ -- thread handler but only a "pseudo" one. It is not possible to release
+ -- the thread handle and free the system resources from this "pseudo"
+ -- handle. So we really want to keep the real thread handle set in
+ -- System.Task_Primitives.Operations.Create_Task during thread creation.
procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
- -- Properly initializes the FPU for x86 systems.
+ -- Properly initializes the FPU for x86 systems
begin
Specific.Set (Self_ID);
Init_Float;
+ if Self_ID.Common.Task_Info /= null
+ and then
+ Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors)
+ then
+ raise Invalid_CPU_Number;
+ end if;
+
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
Lock_RTS;
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
+ Initial_Stack_Size : constant := 1024;
+ -- We set the initial stack size to 1024. On Windows version prior to XP
+ -- there is no way to fix a task stack size. Only the initial stack size
+ -- can be set, the operating system will raise the task stack size if
+ -- needed.
+
+ function Is_Windows_XP return Integer;
+ pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp");
+ -- Returns 1 if running on Windows XP
+
hTask : HANDLE;
TaskId : aliased DWORD;
- pTaskParameter : System.OS_Interface.PVOID;
- dwStackSize : DWORD;
+ pTaskParameter : Win32.PVOID;
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
begin
pTaskParameter := To_Address (T);
- if Stack_Size = Unspecified_Size then
- dwStackSize := DWORD (Default_Stack_Size);
-
- elsif Stack_Size < Minimum_Stack_Size then
- dwStackSize := DWORD (Minimum_Stack_Size);
+ Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
+ if Is_Windows_XP = 1 then
+ hTask := CreateThread
+ (null,
+ DWORD (Stack_Size),
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended) or
+ DWORD (Stack_Size_Param_Is_A_Reservation),
+ TaskId'Unchecked_Access);
else
- dwStackSize := DWORD (Stack_Size);
+ hTask := CreateThread
+ (null,
+ Initial_Stack_Size,
+ Entry_Point,
+ pTaskParameter,
+ DWORD (Create_Suspended),
+ TaskId'Unchecked_Access);
end if;
- Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
-
- hTask := CreateThread
- (null,
- dwStackSize,
- Entry_Point,
- pTaskParameter,
- DWORD (Create_Suspended),
- TaskId'Unchecked_Access);
-
-- Step 1: Create the thread in blocked mode
if hTask = 0 then
- raise Storage_Error;
+ Succeeded := False;
+ return;
end if;
-- Step 2: set its TCB
Set_Priority (T, Priority);
- if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
- -- Here we need Annex E semantics so we disable the NT priority
+ if Time_Slice_Val = 0
+ or else Dispatching_Policy = 'F'
+ or else Get_Policy (Priority) = 'F'
+ then
+ -- Here we need Annex D semantics so we disable the NT priority
-- boost. A priority boost is temporarily given by the system to a
-- thread when it is taken out of a wait state.
- SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE);
+ end if;
+
+ -- Step 4: Handle Task_Info
+
+ if T.Common.Task_Info /= null then
+ if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then
+ Result := SetThreadIdealProcessor (hTask, T.Common.Task_Info.CPU);
+ pragma Assert (Result = 1);
+ end if;
end if;
- -- Step 4: Now, start it for good:
+ -- Step 5: Now, start it for good:
Result := ResumeThread (hTask);
pragma Assert (Result = 1);
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
if Self_ID.Common.LL.Thread /= 0 then
-- This task has been activated. Wait for the thread to terminate
- -- then close it. this is needed to release system ressources.
+ -- then close it. This is needed to release system resources.
Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
pragma Assert (Result /= WAIT_FAILED);
Succeeded := CloseHandle (T.Common.LL.Thread);
- pragma Assert (Succeeded = True);
+ pragma Assert (Succeeded = Win32.TRUE);
end if;
Free (Self_ID);
begin
Environment_Task_Id := Environment_Task;
+ OS_Primitives.Initialize;
+ Interrupt_Management.Initialize;
- if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
-
- -- Here we need Annex E semantics, switch the current process to the
- -- High_Priority_Class.
+ if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
+ -- Here we need Annex D semantics, switch the current process to the
+ -- Realtime_Priority_Class.
- Discard :=
- OS_Interface.SetPriorityClass
- (GetCurrentProcess, High_Priority_Class);
+ Discard := OS_Interface.SetPriorityClass
+ (GetCurrentProcess, Realtime_Priority_Class);
- -- ??? In theory it should be possible to use the priority class
- -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
- -- which prevents (in some obscure cases) a thread to get on top of
- -- the running queue by another thread of lower priority. For
- -- example cxd8002 ACATS test freeze.
+ Annex_D := True;
end if;
TlsIndex := TlsAlloc;
- -- 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);
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, Win32.TRUE, Win32.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 = Win32.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
+ SSL.Abort_Defer.all;
+
+ EnterCriticalSection (S.L'Access);
+
+ S.State := False;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True (S : in out Suspension_Object) is
+ Result : BOOL;
+ begin
+ SSL.Abort_Defer.all;
+
+ 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 = Win32.TRUE);
+ else
+ S.State := True;
+ end if;
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_True (S : in out Suspension_Object) is
+ Result : DWORD;
+ Result_Bool : BOOL;
+ begin
+ SSL.Abort_Defer.all;
+
+ 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);
+
+ SSL.Abort_Undefer.all;
+
+ 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);
+
+ SSL.Abort_Undefer.all;
+ else
+ S.Waiting := True;
+
+ -- Must reset CV BEFORE L is unlocked
+
+ Result_Bool := ResetEvent (S.CV);
+ pragma Assert (Result_Bool = Win32.TRUE);
+
+ LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
+
+ Result := WaitForSingleObject (S.CV, Wait_Infinite);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
-- Check_Exit --
----------------
end if;
end Resume_Task;
+ --------------------
+ -- Stop_All_Tasks --
+ --------------------
+
+ procedure Stop_All_Tasks is
+ begin
+ null;
+ end Stop_All_Tasks;
+
+ ---------------
+ -- Stop_Task --
+ ---------------
+
+ function Stop_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Stop_Task;
+
+ -------------------
+ -- Continue_Task --
+ -------------------
+
+ function Continue_Task (T : ST.Task_Id) return Boolean is
+ pragma Unreferenced (T);
+ begin
+ return False;
+ end Continue_Task;
+
end System.Task_Primitives.Operations;