2009-04-16 Doug Rupp <rupp@adacore.com>

	* s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-mingw.adb,
	s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-irix.adb, 
	s-taprop-hpux-dce.adb, s-taprop-posix.adb
	(Enter_Task): Move Known_Tasks initialization to s-tassta.adb

	* s-taprop-vms.adb (Enter_Task): Likewise.
	(Initialize): Import DBEXT, Debug_Register. Register DBGEXT callback.

	* s-tassta.adb (Activate_Tasks): After task creation set state to
	Activating, vice Runnable. Initialize Known_Tasks, moved here from
	s-taprop.adb (Enter_Task). Set Debug_Event_Activating for debugger.
	Set state to Runnable after above.
	(Task_Wrapper): Set Debug_Event_Run. In exception block set
	Debug_Event_Terminated.

	* s-taskin.ads (Task_States): Add new states Activiting and
	Activator_Delay_Sleep.
	(Bit_Array, Debug_Event_Array): New types.
	(Global_Task_Debug_Event_Set: New flag.
	(Common_ATCB): New field Debug_Events.

	* s-taskin.adb (Initialize_ATCB): Initialize Debug_Events.

	* s-tasren.adb (Timed_Selective_Wait): Set Activator_Delay_Sleep vice
	Activator_Sleep.

	* s-tasini.adb (Locked_Abort_To_Level): Add case alternatives for when
	Activating and when Acceptor_Delay_Sleep.

	* s-tasdeb.ads: Add constants for Debug_Events.
	(Debug_Event_Kind_Type): New subtype.
	(Signal_Debug_Event): New subprogram.

	* s-tasdeb.adb (Signal_Debug_Event): New null subprogram.

From-SVN: r146155

1 files changed, 64 insertions, 60 deletions

diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb
index 57d7dc6..0a97fb0 100644
--- a/gcc/ada/s-tasini.adb
+++ b/gcc/ada/s-tasini.adb
@@ -57,9 +57,9 @@ package body System.Tasking.Initialization is
    use Task_Primitives.Operations;
 
    Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
-   --  This is a global lock; it is used to execute in mutual exclusion
-   --  from all other tasks. It is only used by Task_Lock,
-   --  Task_Unlock, and Final_Task_Unlock.
+   --  This is a global lock; it is used to execute in mutual exclusion from
+   --  all other tasks. It is only used by Task_Lock, Task_Unlock, and
+   --  Final_Task_Unlock.
 
    ----------------------------------------------------------------------
    -- Tasking versions of some services needed by non-tasking programs --
@@ -103,11 +103,10 @@ package body System.Tasking.Initialization is
    ----------------------------
 
    procedure Init_RTS;
-   --  This procedure completes the initialization of the GNARL. The first
-   --  part of the initialization is done in the body of System.Tasking.
-   --  It consists of initializing global locks, and installing tasking
-   --  versions of certain operations used by the compiler. Init_RTS is called
-   --  during elaboration.
+   --  This procedure completes the initialization of the GNARL. The first part
+   --  of the initialization is done in the body of System.Tasking. It consists
+   --  of initializing global locks, and installing tasking versions of certain
+   --  operations used by the compiler. Init_RTS is called during elaboration.
 
    --------------------------
    -- Change_Base_Priority --
@@ -130,7 +129,8 @@ package body System.Tasking.Initialization is
    function Check_Abort_Status return Integer is
       Self_ID : constant Task_Id := Self;
    begin
-      if Self_ID /= null and then Self_ID.Deferral_Level = 0
+      if Self_ID /= null
+        and then Self_ID.Deferral_Level = 0
         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
       then
          return 1;
@@ -271,6 +271,7 @@ package body System.Tasking.Initialization is
                   pragma Assert (not Self_ID.ATC_Hack);
 
                elsif Self_ID.ATC_Hack then
+
                   --  The solution really belongs in the Abort_Signal handler
                   --  for async. entry calls.  The present hack is very
                   --  fragile. It relies that the very next point after
@@ -296,13 +297,14 @@ package body System.Tasking.Initialization is
    -- Final_Task_Unlock --
    -----------------------
 
-   --  This version is only for use in Terminate_Task, when the task
-   --  is relinquishing further rights to its own ATCB.
-   --  There is a very interesting potential race condition there, where
-   --  the old task may run concurrently with a new task that is allocated
-   --  the old tasks (now reused) ATCB.  The critical thing here is to
-   --  not make any reference to the ATCB after the lock is released.
-   --  See also comments on Terminate_Task and Unlock.
+   --  This version is only for use in Terminate_Task, when the task is
+   --  relinquishing further rights to its own ATCB.
+
+   --  There is a very interesting potential race condition there, where the
+   --  old task may run concurrently with a new task that is allocated the old
+   --  tasks (now reused) ATCB. The critical thing here is to not make any
+   --  reference to the ATCB after the lock is released. See also comments on
+   --  Terminate_Task and Unlock.
 
    procedure Final_Task_Unlock (Self_ID : Task_Id) is
    begin
@@ -334,16 +336,17 @@ package body System.Tasking.Initialization is
       Self_Id.Awake_Count := 1;
       Self_Id.Alive_Count := 1;
 
-      Self_Id.Master_Within := Library_Task_Level;
-      --  Normally, a task starts out with internal master nesting level
-      --  one larger than external master nesting level. It is incremented
-      --  to one by Enter_Master, which is called in the task body only if
-      --  the compiler thinks the task may have dependent tasks. There is no
+      --  Normally, a task starts out with internal master nesting level one
+      --  larger than external master nesting level. It is incremented to one
+      --  by Enter_Master, which is called in the task body only if the
+      --  compiler thinks the task may have dependent tasks. There is no
       --  corresponding call to Enter_Master for the environment task, so we
-      --  would need to increment it to 2 here.  Instead, we set it to 3.
-      --  By doing this we reserve the level 2 for server tasks of the runtime
+      --  would need to increment it to 2 here. Instead, we set it to 3. By
+      --  doing this we reserve the level 2 for server tasks of the runtime
       --  system. The environment task does not need to wait for these server
 
+      Self_Id.Master_Within := Library_Task_Level;
+
       --  Initialize lock used to implement mutual exclusion between all tasks
 
       Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
@@ -368,8 +371,8 @@ package body System.Tasking.Initialization is
 
       SSL.Tasking.Init_Tasking_Soft_Links;
 
-      --  Abort is deferred in a new ATCB, so we need to undefer abort
-      --  at this stage to make the environment task abortable.
+      --  Abort is deferred in a new ATCB, so we need to undefer abort at this
+      --  stage to make the environment task abortable.
 
       Undefer_Abort (Environment_Task);
    end Init_RTS;
@@ -381,40 +384,37 @@ package body System.Tasking.Initialization is
    --  Abort a task to the specified ATC nesting level.
    --  Call this only with T locked.
 
-   --  An earlier version of this code contained a call to Wakeup. That
-   --  should not be necessary here, if Abort_Task is implemented correctly,
-   --  since Abort_Task should include the effect of Wakeup. However, the
-   --  above call was in earlier versions of this file, and at least for
-   --  some targets Abort_Task has not been doing Wakeup. It should not
-   --  hurt to uncomment the above call, until the error is corrected for
-   --  all targets.
+   --  An earlier version of this code contained a call to Wakeup. That should
+   --  not be necessary here, if Abort_Task is implemented correctly, since
+   --  Abort_Task should include the effect of Wakeup. However, the above call
+   --  was in earlier versions of this file, and at least for some targets
+   --  Abort_Task has not been doing Wakeup. It should not hurt to uncomment
+   --  the above call, until the error is corrected for all targets.
 
    --  See extended comments in package body System.Tasking.Abort for the
    --  overall design of the implementation of task abort.
    --  ??? there is no such package ???
 
-   --  If the task is sleeping it will be in an abort-deferred region, and
-   --  will not have Abort_Signal raised by Abort_Task. Such an "abort
-   --  deferral" is just to protect the RTS internals, and not necessarily
-   --  required to enforce Ada semantics. Abort_Task should wake the task up
-   --  and let it decide if it wants to complete the aborted construct
-   --  immediately.
+   --  If the task is sleeping it will be in an abort-deferred region, and will
+   --  not have Abort_Signal raised by Abort_Task. Such an "abort deferral" is
+   --  just to protect the RTS internals, and not necessarily required to
+   --  enforce Ada semantics. Abort_Task should wake the task up and let it
+   --  decide if it wants to complete the aborted construct immediately.
 
    --  Note that the effect of the low-level Abort_Task is not persistent.
    --  If the target task is not blocked, this wakeup will be missed.
 
    --  We don't bother calling Abort_Task if this task is aborting itself,
-   --  since we are inside the RTS and have abort deferred. Similarly, We
-   --  don't bother to call Abort_Task if T is terminated, since there is
-   --  no need to abort a terminated task, and it could be dangerous to try
-   --  if the task has stopped executing.
-
-   --  Note that an earlier version of this code had some false reasoning
-   --  about being able to reliably wake up a task that had suspended on
-   --  a blocking system call that does not atomically release the task's
-   --  lock (e.g., UNIX nanosleep, which we once thought could be used to
-   --  implement delays). That still left the possibility of missed
-   --  wakeups.
+   --  since we are inside the RTS and have abort deferred. Similarly, We don't
+   --  bother to call Abort_Task if T is terminated, since there is no need to
+   --  abort a terminated task, and it could be dangerous to try if the task
+   --  has stopped executing.
+
+   --  Note that an earlier version of this code had some false reasoning about
+   --  being able to reliably wake up a task that had suspended on a blocking
+   --  system call that does not atomically release the task's lock (e.g., UNIX
+   --  nanosleep, which we once thought could be used to implement delays).
+   --  That still left the possibility of missed wakeups.
 
    --  We cannot safely call Vulnerable_Complete_Activation here, since that
    --  requires locking Self_ID.Parent. The anti-deadlock lock ordering rules
@@ -436,7 +436,8 @@ package body System.Tasking.Initialization is
                pragma Assert (False);
                null;
 
-            when Runnable =>
+            when Activating | Runnable =>
+
                --  This is needed to cancel an asynchronous protected entry
                --  call during a requeue with abort.
 
@@ -454,7 +455,7 @@ package body System.Tasking.Initialization is
                  AST_Server_Sleep                         =>
                Wakeup (T, T.Common.State);
 
-            when Acceptor_Sleep =>
+            when Acceptor_Sleep | Acceptor_Delay_Sleep =>
                T.Open_Accepts := null;
                Wakeup (T, T.Common.State);
 
@@ -488,13 +489,17 @@ package body System.Tasking.Initialization is
             --  value will not be set to False except with T also locked,
             --  inside Exit_One_ATC_Level, so we should not miss wakeups.
 
-            if T.Common.State = Acceptor_Sleep then
+            if T.Common.State = Acceptor_Sleep
+                 or else
+               T.Common.State = Acceptor_Delay_Sleep
+            then
                T.Open_Accepts := null;
             end if;
 
          elsif T /= Self_ID and then
            (T.Common.State = Runnable
-            or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag)
+             or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag)
+
             --  The task is blocked on a system call waiting for the
             --  completion event. In this case Abort_Task may need to take
             --  special action in order to succeed. Example system: VMS.
@@ -519,7 +524,6 @@ package body System.Tasking.Initialization is
 
       Previous := Null_Task;
       C := All_Tasks_List;
-
       while C /= Null_Task loop
          if C = T then
             if Previous = Null_Task then
@@ -565,7 +569,6 @@ package body System.Tasking.Initialization is
 
    function Task_Name return String is
       Self_Id : constant Task_Id := STPO.Self;
-
    begin
       return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len);
    end Task_Name;
@@ -776,6 +779,7 @@ package body System.Tasking.Initialization is
       New_State  : Entry_Call_State)
    is
       Caller : constant Task_Id := Entry_Call.Self;
+
    begin
       pragma Debug (Debug.Trace
         (Self_ID, "Wakeup_Entry_Caller", 'E', Caller));
@@ -787,8 +791,8 @@ package body System.Tasking.Initialization is
 
       if Entry_Call.Mode = Asynchronous_Call then
 
-         --  Abort the caller in his abortable part,
-         --  but do so only if call has been queued abortably
+         --  Abort the caller in his abortable part, but do so only if call has
+         --  been queued abortably.
 
          if Entry_Call.State >= Was_Abortable or else New_State = Done then
             Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1);
@@ -804,9 +808,9 @@ package body System.Tasking.Initialization is
    -----------------------
 
    --  These are dummies for subprograms that are only needed by certain
-   --  optional run-time system packages. If they are needed, the soft
-   --  links will be redirected to the real subprogram by elaboration of
-   --  the subprogram body where the real subprogram is declared.
+   --  optional run-time system packages. If they are needed, the soft links
+   --  will be redirected to the real subprogram by elaboration of the
+   --  subprogram body where the real subprogram is declared.
 
    procedure Finalize_Attributes (T : Task_Id) is
       pragma Unreferenced (T);