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, 99 insertions, 60 deletions

diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb
index c945f5c9d7e..8d149590fbc 100644
--- a/gcc/ada/s-taprop-linux.adb
+++ b/gcc/ada/s-taprop-linux.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- --
@@ -71,8 +71,8 @@ with Ada.Exceptions;
 --           Raise_From_Signal_Handler
 --           Exception_Id
 
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
 
 package body System.Task_Primitives.Operations is
 
@@ -110,8 +110,7 @@ package body System.Task_Primitives.Operations is
    --  The followings are internal configuration constants needed
 
    Next_Serial_Number : Task_Serial_Number := 100;
-   --  We start at 100, to reserve some special values for
-   --  using in error checking.
+   --  We start at 100 (reserve some special values for using in error checks)
 
    Time_Slice_Val : Integer;
    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@@ -119,8 +118,8 @@ package body System.Task_Primitives.Operations is
    Dispatching_Policy : Character;
    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 
-   --  The following are effectively constants, but they need to
-   --  be initialized by calling a pthread_ function.
+   --  The following are effectively constants, but they need to be initialized
+   --  by calling a pthread_ function.
 
    Mutex_Attr   : aliased pthread_mutexattr_t;
    Cond_Attr    : aliased pthread_condattr_t;
@@ -173,7 +172,7 @@ package body System.Task_Primitives.Operations is
 
    procedure Abort_Handler (signo : Signal);
 
-   function To_pthread_t is new Unchecked_Conversion
+   function To_pthread_t is new Ada.Unchecked_Conversion
      (unsigned_long, System.OS_Interface.pthread_t);
 
    -------------------
@@ -200,8 +199,11 @@ package body System.Task_Primitives.Operations is
 
          --  Make sure signals used for RTS internal purpose are unmasked
 
-         Result := pthread_sigmask (SIG_UNBLOCK,
-           Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+         Result :=
+           pthread_sigmask
+             (SIG_UNBLOCK,
+              Unblocked_Signal_Mask'Unchecked_Access,
+              Old_Set'Unchecked_Access);
          pragma Assert (Result = 0);
 
          raise Standard'Abort_Signal;
@@ -272,6 +274,7 @@ package body System.Task_Primitives.Operations is
       pragma Unreferenced (Prio);
 
       Result : Interfaces.C.int;
+
    begin
       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 
@@ -284,7 +287,8 @@ package body System.Task_Primitives.Operations is
    end Initialize_Lock;
 
    procedure Initialize_Lock
-     (L : not null access RTS_Lock; Level : Lock_Level)
+     (L     : not null access RTS_Lock;
+      Level : Lock_Level)
    is
       pragma Unreferenced (Level);
 
@@ -323,7 +327,8 @@ package body System.Task_Primitives.Operations is
    ----------------
 
    procedure Write_Lock
-     (L : not null access Lock; Ceiling_Violation : out Boolean)
+     (L                 : not null access Lock;
+      Ceiling_Violation : out Boolean)
    is
       Result : Interfaces.C.int;
    begin
@@ -361,7 +366,9 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Read_Lock
-     (L : not null access Lock; Ceiling_Violation : out Boolean) is
+     (L                 : not null access Lock;
+      Ceiling_Violation : out Boolean)
+   is
    begin
       Write_Lock (L, Ceiling_Violation);
    end Read_Lock;
@@ -378,7 +385,8 @@ package body System.Task_Primitives.Operations is
    end Unlock;
 
    procedure Unlock
-     (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+     (L           : not null access RTS_Lock;
+      Global_Lock : Boolean := False)
    is
       Result : Interfaces.C.int;
    begin
@@ -397,6 +405,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 --
    -----------
@@ -413,11 +436,13 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Self_ID = Self);
 
       if Single_Lock then
-         Result := pthread_cond_wait
-           (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+         Result :=
+           pthread_cond_wait
+             (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
       else
-         Result := pthread_cond_wait
-           (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+         Result :=
+           pthread_cond_wait
+             (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
       end if;
 
       --  EINTR is not considered a failure
@@ -443,7 +468,8 @@ package body System.Task_Primitives.Operations is
    is
       pragma Unreferenced (Reason);
 
-      Check_Time : constant Duration := Monotonic_Clock;
+      Base_Time  : constant Duration := Monotonic_Clock;
+      Check_Time : Duration := Base_Time;
       Abs_Time   : Duration;
       Request    : aliased timespec;
       Result     : Interfaces.C.int;
@@ -462,24 +488,30 @@ package body System.Task_Primitives.Operations is
          Request := To_Timespec (Abs_Time);
 
          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
-               Result := pthread_cond_timedwait
-                 (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
-                  Request'Access);
+               Result :=
+                 pthread_cond_timedwait
+                   (Self_ID.Common.LL.CV'Access,
+                    Single_RTS_Lock'Access,
+                    Request'Access);
 
             else
-               Result := pthread_cond_timedwait
-                 (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
-                  Request'Access);
+               Result :=
+                 pthread_cond_timedwait
+                   (Self_ID.Common.LL.CV'Access,
+                    Self_ID.Common.LL.L'Access,
+                    Request'Access);
             end if;
 
-            exit when Abs_Time <= Monotonic_Clock;
+            Check_Time := Monotonic_Clock;
+            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+            if Result = 0 or else Result = EINTR then
+
+               --  Somebody may have called Wakeup for us
 
-            if Result = 0 or Result = EINTR then
-               --  somebody may have called Wakeup for us
                Timedout := False;
                exit;
             end if;
@@ -493,16 +525,16 @@ package body System.Task_Primitives.Operations is
    -- Timed_Delay --
    -----------------
 
-   --  This is for use in implementing delay statements, so
-   --  we assume the caller is abort-deferred but is holding
-   --  no locks.
+   --  This is for use in implementing delay statements, so we assume the
+   --  caller is abort-deferred but is holding no locks.
 
    procedure Timed_Delay
      (Self_ID : Task_Id;
       Time    : Duration;
       Mode    : ST.Delay_Modes)
    is
-      Check_Time : constant Duration := Monotonic_Clock;
+      Base_Time  : constant Duration := Monotonic_Clock;
+      Check_Time : Duration := Base_Time;
       Abs_Time   : Duration;
       Request    : aliased timespec;
 
@@ -527,12 +559,6 @@ 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
@@ -547,7 +573,8 @@ package body System.Task_Primitives.Operations is
                             Request'Access);
             end if;
 
-            exit when Abs_Time <= Monotonic_Clock;
+            Check_Time := Monotonic_Clock;
+            exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 
             pragma Assert (Result = 0 or else
               Result = ETIMEDOUT or else
@@ -638,8 +665,7 @@ package body System.Task_Primitives.Operations is
    begin
       T.Common.Current_Priority := Prio;
 
-      --  Priorities are in range 1 .. 99 on GNU/Linux, so we map
-      --  map 0 .. 98 to 1 .. 99
+      --  Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
 
       Param.sched_priority := Interfaces.C.int (Prio) + 1;
 
@@ -647,20 +673,24 @@ package body System.Task_Primitives.Operations is
         or else Priority_Specific_Policy = 'R'
         or else Time_Slice_Val > 0
       then
-         Result := pthread_setschedparam
-           (T.Common.LL.Thread, SCHED_RR, Param'Access);
+         Result :=
+           pthread_setschedparam
+             (T.Common.LL.Thread, SCHED_RR, Param'Access);
 
       elsif Dispatching_Policy = 'F'
         or else Priority_Specific_Policy = 'F'
         or else Time_Slice_Val = 0
       then
-         Result := pthread_setschedparam
-           (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+         Result :=
+           pthread_setschedparam
+             (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 
       else
          Param.sched_priority := 0;
-         Result := pthread_setschedparam
-           (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+         Result :=
+           pthread_setschedparam
+             (T.Common.LL.Thread,
+              SCHED_OTHER, Param'Access);
       end if;
 
       pragma Assert (Result = 0 or else Result = EPERM);
@@ -832,7 +862,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
@@ -870,8 +900,10 @@ package body System.Task_Primitives.Operations is
    procedure Abort_Task (T : Task_Id) is
       Result : Interfaces.C.int;
    begin
-      Result := pthread_kill (T.Common.LL.Thread,
-        Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+      Result :=
+        pthread_kill
+          (T.Common.LL.Thread,
+           Signal (System.Interrupt_Management.Abort_Task_Interrupt));
       pragma Assert (Result = 0);
    end Abort_Task;
 
@@ -881,9 +913,9 @@ package body System.Task_Primitives.Operations is
 
    procedure Initialize (S : in out Suspension_Object) is
       Result : Interfaces.C.int;
+
    begin
-      --  Initialize internal state. It is always initialized to False (ARM
-      --  D.10 par. 6).
+      --  Initialize internal state (always to False (RM D.10(6)))
 
       S.State := False;
       S.Waiting := False;
@@ -919,7 +951,8 @@ package body System.Task_Primitives.Operations is
    --------------
 
    procedure Finalize (S : in out Suspension_Object) is
-      Result  : Interfaces.C.int;
+      Result : Interfaces.C.int;
+
    begin
       --  Destroy internal mutex
 
@@ -949,7 +982,8 @@ package body System.Task_Primitives.Operations is
    ---------------
 
    procedure Set_False (S : in out Suspension_Object) is
-      Result  : Interfaces.C.int;
+      Result : Interfaces.C.int;
+
    begin
       SSL.Abort_Defer.all;
 
@@ -970,6 +1004,7 @@ package body System.Task_Primitives.Operations is
 
    procedure Set_True (S : in out Suspension_Object) is
       Result : Interfaces.C.int;
+
    begin
       SSL.Abort_Defer.all;
 
@@ -987,6 +1022,7 @@ package body System.Task_Primitives.Operations is
 
          Result := pthread_cond_signal (S.CV'Access);
          pragma Assert (Result = 0);
+
       else
          S.State := True;
       end if;
@@ -1003,6 +1039,7 @@ package body System.Task_Primitives.Operations is
 
    procedure Suspend_Until_True (S : in out Suspension_Object) is
       Result : Interfaces.C.int;
+
    begin
       SSL.Abort_Defer.all;
 
@@ -1010,9 +1047,10 @@ package body System.Task_Primitives.Operations is
       pragma Assert (Result = 0);
 
       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).
+         --  (RM D.10(10)).
 
          Result := pthread_mutex_unlock (S.L'Access);
          pragma Assert (Result = 0);
@@ -1036,7 +1074,8 @@ package body System.Task_Primitives.Operations is
          pragma Assert (Result = 0);
 
          SSL.Abort_Undefer.all;
-      end if;
+      end
+      if;
    end Suspend_Until_True;
 
    ----------------
@@ -1159,8 +1198,8 @@ package body System.Task_Primitives.Operations is
 
       --  Install the abort-signal handler
 
-      if State (System.Interrupt_Management.Abort_Task_Interrupt)
-        /= Default
+      if State
+          (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
       then
          act.sa_flags := 0;
          act.sa_handler := Abort_Handler'Address;