-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- ware Foundation; either version 3, 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 GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- 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. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- 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.
-
-with System.Tasking.Debug;
--- used for Known_Tasks
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.OS_Primitives;
--- used for Delay_Modes
+with Ada.Unchecked_Deallocation;
with Interfaces.C;
--- used for int
--- size_t
-
with Interfaces.C.Strings;
--- used for Null_Ptr
+with System.Tasking.Debug;
+with System.OS_Primitives;
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=0x200000,0x1000");
-- Change the default stack size (2 MB) for tasking programs on Windows.
-- 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.
+ ---------------------
+ -- 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 --
----------------
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+ 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)
+ 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
+ -- WaitForSingleObject will simply not block.
if Rel_Time <= 0.0 then
Timed_Out := True;
Wait_Result := 0;
else
- if Rel_Time >= Duration (Time_Out_Max) / 1000 then
- Time_Out := Time_Out_Max;
- else
- Time_Out := DWORD (Rel_Time * 1000);
- end if;
+ Time_Out :=
+ (if Rel_Time >= Duration (Time_Out_Max) / 1000
+ then Time_Out_Max
+ else DWORD (Rel_Time * 1000));
Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
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;
+
+ Timedout : Boolean;
+ Result : Integer;
+ pragma Unreferenced (Timedout, Result);
begin
if Single_Lock then
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;
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 Dispatching_Policy = 'F' 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;
- Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
-
- Lock_RTS;
-
- for J in Known_Tasks'Range loop
- if Known_Tasks (J) = null then
- Known_Tasks (J) := Self_ID;
- Self_ID.Known_Tasks_Index := J;
- exit;
- end if;
- end loop;
+ 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;
- Unlock_RTS;
+ Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
end Enter_Task;
--------------
hTask : HANDLE;
TaskId : aliased DWORD;
- pTaskParameter : System.OS_Interface.PVOID;
+ pTaskParameter : Win32.PVOID;
Result : DWORD;
Entry_Point : PTHREAD_START_ROUTINE;
-- 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 Dispatching_Policy = 'F' 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: Now, start it for good:
+ -- 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 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 Dispatching_Policy = 'F' then
-
-- Here we need Annex D semantics, switch the current process to the
- -- High_Priority_Class.
+ -- 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);
Environment_Task.Common.LL.Thread := GetCurrentThread;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
Enter_Task (Environment_Task);
end Initialize;
-- Initialize internal condition variable
- S.CV := CreateEvent (null, True, False, Null_Ptr);
+ S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr);
pragma Assert (S.CV /= 0);
end Initialize;
-- Destroy internal condition variable
Result := CloseHandle (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
end Finalize;
-------------------
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;
--------------
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
S.State := False;
Result := SetEvent (S.CV);
- pragma Assert (Result = True);
+ pragma Assert (Result = Win32.TRUE);
else
S.State := True;
end if;
LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
end Set_True;
------------------------
Result : DWORD;
Result_Bool : BOOL;
begin
+ SSL.Abort_Defer.all;
+
EnterCriticalSection (S.L'Access);
if S.Waiting then
LeaveCriticalSection (S.L'Access);
+ SSL.Abort_Undefer.all;
+
raise Program_Error;
else
-- Suspend the task if the state is False. Otherwise, the task
S.State := False;
LeaveCriticalSection (S.L'Access);
+
+ SSL.Abort_Undefer.all;
else
S.Waiting := True;
- -- Must reset CV BEFORE L is unlocked.
+ -- Must reset CV BEFORE L is unlocked
Result_Bool := ResetEvent (S.CV);
- pragma Assert (Result_Bool = True);
+ 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 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;
OSDN Git Service
