diff options
Diffstat (limited to 'gcc/ada/s-taprop-mingw.adb')
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 143 |
1 files changed, 79 insertions, 64 deletions
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 5656932face..1c979355b20 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -62,12 +62,12 @@ with System.Interrupt_Management; with System.Soft_Links; -- used for Abort_Defer/Undefer --- 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 +-- 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. -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -113,6 +113,9 @@ package body System.Task_Primitives.Operations is 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 -- ------------------------------------ @@ -200,7 +203,6 @@ package body System.Task_Primitives.Operations is procedure Initialize_Cond (Cond : not null access Condition_Variable) is hEvent : HANDLE; - begin hEvent := CreateEvent (null, True, False, Null_Ptr); pragma Assert (hEvent /= 0); @@ -236,10 +238,10 @@ package body System.Task_Primitives.Operations is -- 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 @@ -254,7 +256,7 @@ package body System.Task_Primitives.Operations is Result_Bool := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result_Bool = True); - Unlock (L); + Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, -- WaitForSingleObject will simply not block @@ -262,17 +264,17 @@ 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 @@ -283,19 +285,18 @@ package body System.Task_Primitives.Operations is 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 Result := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result = True); - Unlock (L); + Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, -- WaitForSingleObject will simply not block @@ -321,7 +322,7 @@ package body System.Task_Primitives.Operations is end if; end if; - Write_Lock (L); + Write_Lock (L, Global_Lock => True); -- Ensure post-condition @@ -337,14 +338,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; @@ -376,12 +375,11 @@ 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 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. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -487,6 +485,21 @@ package body System.Task_Primitives.Operations is 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 -- ----------- @@ -518,9 +531,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; @@ -552,15 +564,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; @@ -615,22 +630,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; @@ -668,7 +679,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; @@ -748,7 +769,7 @@ package body System.Task_Primitives.Operations is -- 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. + -- 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 @@ -923,7 +944,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 @@ -1014,19 +1035,13 @@ package body System.Task_Primitives.Operations is 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_Priority_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; |