2007-04-20 Arnaud Charlet <charlet@adacore.com>

	* s-taprop-vms.adb, s-taprop-hpux-dce.adb, s-taprop-vxworks.adb, 
	s-osprim-posix.adb, s-taprop-posix.adb, s-osprim-vxworks.adb, 
	s-taprop-solaris.adb, s-osprim-solaris.adb, s-taprop-dummy.adb, 
	s-osprim-unix.adb, s-osinte-freebsd.adb, s-osinte-freebsd.ads, 
	s-osinte-lynxos.adb, s-osinte-lynxos.ads, s-taprop-tru64.adb, 
	s-taprop-lynxos.adb, s-taprop-irix.adb, s-osinte-tru64.adb, 
	s-osinte-tru64.ads, s-taprop-linux.adb, s-parame.ads, 
	s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, s-parame-hpux.ads, 
	s-parame-vms-restrict.ads, s-parame-ae653.ads, s-parame-vxworks.ads, 
	s-taprop-mingw.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb,
        s-osprim-mingw.adb (Timed_Delay, Timed_Sleep): Register the base
	time when entering this routine to detect a backward clock setting
	(manual setting or DST adjustment), to avoid waiting for a longer delay
	than needed.
	(Time_Duration, To_Timeval, struct_timeval): Removed when not relevant.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.
	Update comments.
	(Max_Task_Image_Length): New constant.
	Replace Warnings (Off) by Unreferenced pragma, cleaner.
	(Dynamic_Priority_Support): Removed, no longer needed.
	(Poll_Base_Priority_Change): Ditto.
	(Set_Ceiling): Add this procedure to change the ceiling priority
	associated to a lock. This is a dummy implementation because dynamic
	priority ceilings are not supported by the underlying system.

	* a-dynpri.adb (Set_Priority): Take into account case where Target is
	accepting a RV with its priority boosted.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.

	* s-taenca.adb (Try_To_Cancel_Entry_Call): Remove special case for
	Succeeded = True.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.
	(Wait_For_Completion, Wait_For_Call, Timed_Selective_Wait): Change state
	of Self_Id earlier.

	* s-tasini.ads, s-tasini.adb (Wakeup_Entry_Caller): Relax assertion.
	(Poll_Base_Priority_Change): Removed.
	Code clean up: use SSL.Current_Target_Exception.

	* s-tasren.adb (Task_Count): Call Yield to let a chance to other tasks
	to run as this is a potentially dispatching point.
	(Call_Synchronous): Use Local_Defer_Abort.
	(Callable): Relax assertion.
	(Selective_Wait): Relax assertion in case abort is not allowed.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.

	* s-tasuti.adb (Make_Passive): Adjust assertions.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125364 138bc75d-0d04-0410-961f-82ee72b054a4

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;