X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fs-taprop-mingw.adb;h=a3b19ab5c5df7aa0a8f150f4c1e69672643f2298;hb=76009c8a6736b5f1b122a7f3ed7560c60c5c8165;hp=7280f646dd26c4f183432eab2b178ce7f629dfc6;hpb=e11441b606ae5dbf70d412effa06b036e897e5d3;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 7280f646dd2..a3b19ab5c5d 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -6,25 +6,23 @@ -- -- -- 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 -- +-- . -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- @@ -33,33 +31,34 @@ -- 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; @@ -67,6 +66,9 @@ package body System.Task_Primitives.Operations is 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. @@ -75,6 +77,30 @@ package body System.Task_Primitives.Operations is -- 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 -- ---------------- @@ -93,9 +119,16 @@ package body System.Task_Primitives.Operations is 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 -- ------------------------------------ @@ -117,7 +150,7 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task end Specific; @@ -132,7 +165,7 @@ package body System.Task_Primitives.Operations is Succeeded : BOOL; begin Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); - pragma Assert (Succeeded = True); + pragma Assert (Succeeded = Win32.TRUE); end Set; end Specific; @@ -142,7 +175,7 @@ package body System.Task_Primitives.Operations is --------------------------------- 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; @@ -151,23 +184,23 @@ package body System.Task_Primitives.Operations is -- 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); @@ -181,11 +214,10 @@ package body System.Task_Primitives.Operations is -- 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; @@ -197,47 +229,47 @@ package body System.Task_Primitives.Operations is -- 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 @@ -245,54 +277,52 @@ package body System.Task_Primitives.Operations is 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); @@ -304,13 +334,13 @@ package body System.Task_Primitives.Operations is 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); @@ -320,14 +350,12 @@ package body System.Task_Primitives.Operations is -- 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; @@ -359,16 +387,15 @@ package body System.Task_Primitives.Operations is -- 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); @@ -376,31 +403,34 @@ package body System.Task_Primitives.Operations is 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); @@ -415,20 +445,19 @@ package body System.Task_Primitives.Operations is 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; @@ -436,7 +465,8 @@ package body System.Task_Primitives.Operations is -- 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; @@ -445,26 +475,41 @@ package body System.Task_Primitives.Operations is -- 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 -- ----------- @@ -496,9 +541,8 @@ package body System.Task_Primitives.Operations is -- 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; @@ -512,7 +556,9 @@ package body System.Task_Primitives.Operations is Check_Time : Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; - Result : Integer; + + Result : Integer; + pragma Unreferenced (Result); Local_Timedout : Boolean; @@ -530,15 +576,18 @@ package body System.Task_Primitives.Operations is 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; @@ -562,15 +611,17 @@ package body System.Task_Primitives.Operations is ----------------- 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 @@ -591,20 +642,18 @@ package body System.Task_Primitives.Operations is 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; @@ -642,7 +691,17 @@ package body System.Task_Primitives.Operations is 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; @@ -671,9 +730,9 @@ package body System.Task_Primitives.Operations is 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 @@ -721,38 +780,32 @@ package body System.Task_Primitives.Operations is -- 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; -------------- @@ -826,7 +879,7 @@ package body System.Task_Primitives.Operations is hTask : HANDLE; TaskId : aliased DWORD; - pTaskParameter : System.OS_Interface.PVOID; + pTaskParameter : Win32.PVOID; Result : DWORD; Entry_Point : PTHREAD_START_ROUTINE; @@ -857,7 +910,8 @@ package body System.Task_Primitives.Operations is -- 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 @@ -868,15 +922,27 @@ package body System.Task_Primitives.Operations is 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); @@ -895,7 +961,7 @@ package body System.Task_Primitives.Operations is 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 @@ -911,12 +977,12 @@ package body System.Task_Primitives.Operations is 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); @@ -983,30 +1049,32 @@ package body System.Task_Primitives.Operations is 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; @@ -1044,7 +1112,7 @@ package body System.Task_Primitives.Operations is -- 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; @@ -1062,7 +1130,7 @@ package body System.Task_Primitives.Operations is -- Destroy internal condition variable Result := CloseHandle (S.CV); - pragma Assert (Result = True); + pragma Assert (Result = Win32.TRUE); end Finalize; ------------------- @@ -1083,11 +1151,15 @@ package body System.Task_Primitives.Operations is 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; -------------- @@ -1097,6 +1169,8 @@ package body System.Task_Primitives.Operations is 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 @@ -1109,12 +1183,14 @@ package body System.Task_Primitives.Operations is 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; ------------------------ @@ -1125,6 +1201,8 @@ package body System.Task_Primitives.Operations is Result : DWORD; Result_Bool : BOOL; begin + SSL.Abort_Defer.all; + EnterCriticalSection (S.L'Access); if S.Waiting then @@ -1134,6 +1212,8 @@ package body System.Task_Primitives.Operations is LeaveCriticalSection (S.L'Access); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1144,16 +1224,20 @@ package body System.Task_Primitives.Operations is 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; @@ -1215,4 +1299,33 @@ package body System.Task_Primitives.Operations is 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;