From 5e44c5eab4a57d237cc1078bc0b57018b4915b51 Mon Sep 17 00:00:00 2001 From: Doug Rupp Date: Thu, 16 Apr 2009 09:34:40 +0000 Subject: [PATCH] 2009-04-16 Doug Rupp * 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 --- gcc/ada/ChangeLog | 37 ++++++++++ gcc/ada/s-taprop-hpux-dce.adb | 12 ---- gcc/ada/s-taprop-irix.adb | 12 ---- gcc/ada/s-taprop-linux.adb | 12 ---- gcc/ada/s-taprop-mingw.adb | 12 ---- gcc/ada/s-taprop-posix.adb | 12 ---- gcc/ada/s-taprop-solaris.adb | 12 ---- gcc/ada/s-taprop-tru64.adb | 13 +--- gcc/ada/s-taprop-vms.adb | 41 +++++++---- gcc/ada/s-taprop-vxworks.adb | 12 ---- gcc/ada/s-tasdeb.adb | 12 ++++ gcc/ada/s-tasdeb.ads | 20 ++++++ gcc/ada/s-tasini.adb | 124 ++++++++++++++++++---------------- gcc/ada/s-taskin.adb | 31 +++++---- gcc/ada/s-taskin.ads | 26 +++++-- gcc/ada/s-tasren.adb | 10 +-- gcc/ada/s-tassta.adb | 38 ++++++++++- 17 files changed, 243 insertions(+), 193 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 92ae20a8fac..7c1000579f5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2009-04-16 Doug Rupp + + * 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. + 2009-04-16 Thomas Quinot * sem_elim.adb: Minor reformatting diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 21b393c6769..0afd56b6360 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -714,18 +714,6 @@ package body System.Task_Primitives.Operations is begin Self_ID.Common.LL.Thread := pthread_self; Specific.Set (Self_ID); - - 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; - - Unlock_RTS; end Enter_Task; -------------- diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index e86badb118b..d3344b35eaa 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -709,18 +709,6 @@ package body System.Task_Primitives.Operations is (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); pragma Assert (Result = 0); end if; - - 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; - - Unlock_RTS; end Enter_Task; -------------- diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index addffde9bef..d3597a2a242 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -705,18 +705,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); - 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; - - Unlock_RTS; - if Use_Alternate_Stack then declare Stack : aliased stack_t; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 89e7dc13811..f32d426eda8 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -807,18 +807,6 @@ package body System.Task_Primitives.Operations is end if; 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; - - Unlock_RTS; end Enter_Task; -------------- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 64bf28f2670..51f20a6cc9c 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -788,18 +788,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); - 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; - - Unlock_RTS; - if Use_Alternate_Stack then declare Stack : aliased stack_t; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 16da81c446a..4156e368b66 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -900,18 +900,6 @@ package body System.Task_Primitives.Operations is -- We need the above code even if we do direct fetch of Task_Id in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. - - 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; - - Unlock_RTS; end Enter_Task; -------------- diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index ce4195b8029..94649e2ae94 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -707,19 +707,8 @@ package body System.Task_Primitives.Operations is begin Hide_Unhide_Yellow_Zone (Hide => True); Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - - 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; - Unlock_RTS; + Specific.Set (Self_ID); end Enter_Task; -------------- diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 4a36f8b1254..cc640a8ac16 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -689,20 +689,7 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is begin Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - - 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; - - Unlock_RTS; end Enter_Task; -------------- @@ -1238,6 +1225,25 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (Environment_Task : Task_Id) is + + -- The DEC Ada facility code defined in Starlet + Ada_Facility : constant := 49; + + function DBGEXT (Control_Block : System.Address) + return System.Aux_DEC.Unsigned_Word; + -- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed + -- as Address to avoid having a VMS specific s-tasdeb.ads. + pragma Interface (C, DBGEXT); + pragma Import_Function (DBGEXT, "GNAT$DBGEXT"); + + type Facility_Type is range 0 .. 65535; + + procedure Debug_Register + (ADBGEXT : System.Address; + ATCB_Key : pthread_key_t; + Facility : Facility_Type; + Std_Prolog : Integer); + pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER"); begin Environment_Task_Id := Environment_Task; @@ -1249,6 +1255,15 @@ package body System.Task_Primitives.Operations is Specific.Initialize (Environment_Task); + -- Pass the context key on to CMA along with the other parameters + Debug_Register + ( + DBGEXT'Address, -- Our DEBUG handling entry point + ATCB_Key, -- CMA context key for our Ada TCB's + Ada_Facility, -- Out facility code + 0 -- False, we don't have the std TCB prolog + ); + Enter_Task (Environment_Task); end Initialize; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 40ded21b2ac..5f6d8d48202 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -833,18 +833,6 @@ package body System.Task_Primitives.Operations is Install_Signal_Handlers; - 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; - - Unlock_RTS; - -- If stack checking is enabled, set the stack limit for this task if Set_Stack_Limit_Hook /= null then diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index 77d5478c528..9fb0cd6e798 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/gcc/ada/s-tasdeb.adb @@ -246,6 +246,18 @@ package body System.Tasking.Debug is STPO.Self.User_State := Value; end Set_User_State; + ------------------------ + -- Signal_Debug_Event -- + ------------------------ + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id) + is + begin + null; + end Signal_Debug_Event; + -------------------- -- Stop_All_Tasks -- -------------------- diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads index 1314e64753c..806fe0ee7b6 100644 --- a/gcc/ada/s-tasdeb.ads +++ b/gcc/ada/s-tasdeb.ads @@ -69,6 +69,26 @@ package System.Tasking.Debug is -- Global array of tasks read by gdb, and updated by Create_Task and -- Finalize_TCB + Debug_Event_Activating : constant := 1; + Debug_Event_Run : constant := 2; + Debug_Event_Suspended : constant := 3; + Debug_Event_Preempted : constant := 4; + Debug_Event_Terminated : constant := 5; + Debug_Event_Abort_Terminated : constant := 6; + Debug_Event_Exception_Terminated : constant := 7; + Debug_Event_Rendezvous_Exception : constant := 8; + Debug_Event_Handled : constant := 9; + Debug_Event_Dependents_Exception : constant := 10; + Debug_Event_Handled_Others : constant := 11; + + subtype Event_Kind_Type is Positive range 1 .. 11; + -- Event kinds currently defined for debugging, used globally + -- below and on a per taak basis. + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id); + ---------------------------------- -- VxWorks specific GDB support -- ---------------------------------- diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 57d7dc60b63..0a97fb09a25 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); diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 10ad198bfa2..8cc9d91df25 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -62,9 +62,9 @@ package body System.Tasking is function Detect_Blocking return Boolean is GL_Detect_Blocking : Integer; pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); - -- Global variable exported by the binder generated file. - -- A value equal to 1 indicates that pragma Detect_Blocking is active, - -- while 0 is used for the pragma not being present. + -- Global variable exported by the binder generated file. A value equal + -- to 1 indicates that pragma Detect_Blocking is active, while 0 is used + -- for the pragma not being present. begin return GL_Detect_Blocking = 1; @@ -101,7 +101,8 @@ package body System.Tasking is Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; T : Task_Id; - Success : out Boolean) is + Success : out Boolean) + is begin T.Common.State := Unactivated; @@ -128,14 +129,18 @@ package body System.Tasking is T.Common.Global_Task_Lock_Nesting := 0; T.Common.Fall_Back_Handler := null; T.Common.Specific_Handler := null; + T.Common.Debug_Events := + (False, False, False, False, False, False, False, False, + False, False, False, False, False, False, False, False); + -- Wouldn't (others => False) be clearer ??? if T.Common.Parent = null then - -- For the environment task, the adjusted stack size is - -- meaningless. For example, an unspecified Stack_Size means - -- that the stack size is determined by the environment, or - -- can grow dynamically. The Stack_Checking algorithm - -- therefore needs to use the requested size, or 0 in - -- case of an unknown size. + + -- For the environment task, the adjusted stack size is meaningless. + -- For example, an unspecified Stack_Size means that the stack size + -- is determined by the environment, or can grow dynamically. The + -- Stack_Checking algorithm therefore needs to use the requested + -- size, or 0 in case of an unknown size. T.Common.Compiler_Data.Pri_Stack_Info.Size := Storage_Elements.Storage_Offset (Stack_Size); @@ -161,9 +166,9 @@ package body System.Tasking is Main_Priority : Integer; pragma Import (C, Main_Priority, "__gl_main_priority"); - -- Priority for main task. Note that this is of type Integer, not - -- Priority, because we use the value -1 to indicate the default - -- main priority, and that is of course not in Priority'range. + -- Priority for main task. Note that this is of type Integer, not Priority, + -- because we use the value -1 to indicate the default main priority, and + -- that is of course not in Priority'range. Initialized : Boolean := False; -- Used to prevent multiple calls to Initialize diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 1041c039e50..5912eac7f37 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -128,18 +128,18 @@ package System.Tasking is type Task_States is (Unactivated, - -- Task has been created but has not been activated. + -- TCB initialized but not task has not been created. -- It cannot be executing. + Activating, + -- Task has been created and is being made Runnable. + -- Active states -- For all states from here down, the task has been activated. -- For all states from here down, except for Terminated, the task -- may be executing. -- Activator = null iff it has not yet completed activating. - -- For all states from here down, - -- the task has been activated, and may be executing. - Runnable, -- Task is not blocked for any reason known to Ada. -- (It may be waiting for a mutex, though.) @@ -154,7 +154,10 @@ package System.Tasking is -- Task is waiting for created tasks to complete activation Acceptor_Sleep, - -- Task is waiting on an accept or selective wait statement + -- Task is waiting on an accept or select with terminate + + Acceptor_Delay_Sleep, + -- Task is waiting on an selective wait statement Entry_Caller_Sleep, -- Task is waiting on an entry call @@ -389,6 +392,15 @@ package System.Tasking is -- is in general a non-static value that can depend on discriminants -- of the task. + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Debug_Event_Array is Bit_Array (1 .. 16); + + Global_Task_Debug_Event_Set : Boolean := False; + -- Set True when running under debugger control and a task debug + -- event signal has been requested. + ---------------------------------------------- -- Ada_Task_Control_Block (ATCB) definition -- ---------------------------------------------- @@ -608,6 +620,10 @@ package System.Tasking is -- any of its dependent tasks. -- -- Protection: Self.L + + Debug_Events : Debug_Event_Array; + -- Word length array of per task debug events, of which 11 kinds are + -- currently defined in System.Tasking.Debugging package. end record; --------------------------------------- diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index bf5fd85dfb8..38f179d0e2e 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -1525,7 +1525,7 @@ package body System.Tasking.Rendezvous is -- Wait for a normal call and a pending action until the -- Wakeup_Time is reached. - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Common.State := Acceptor_Delay_Sleep; -- Try to remove calls to Sleep in the loop below by letting the -- caller a chance of getting ready immediately, using Unlock @@ -1557,7 +1557,7 @@ package body System.Tasking.Rendezvous is exit when Self_Id.Open_Accepts = null; if Timedout then - Sleep (Self_Id, Acceptor_Sleep); + Sleep (Self_Id, Acceptor_Delay_Sleep); else if Parameters.Runtime_Traces then Send_Trace_Info (WT_Select, @@ -1567,7 +1567,7 @@ package body System.Tasking.Rendezvous is end if; STPO.Timed_Sleep (Self_Id, Timeout, Mode, - Acceptor_Sleep, Timedout, Yielded); + Acceptor_Delay_Sleep, Timedout, Yielded); end if; if Timedout then @@ -1613,9 +1613,9 @@ package body System.Tasking.Rendezvous is -- 3) Spurious wakeup Self_Id.Open_Accepts := null; - Self_Id.Common.State := Acceptor_Sleep; + Self_Id.Common.State := Acceptor_Delay_Sleep; - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, Timedout, Yielded); Self_Id.Common.State := Runnable; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 9a5ce9fd8c1..5d4e7cbd9ad 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -300,7 +300,7 @@ package body System.Tasking.Stages is -- racing ahead. if Success then - C.Common.State := Runnable; + C.Common.State := Activating; C.Awake_Count := 1; C.Alive_Count := 1; P.Awake_Count := P.Awake_Count + 1; @@ -313,6 +313,21 @@ package body System.Tasking.Stages is P.Common.Wait_Count := P.Common.Wait_Count + 1; end if; + for J in System.Tasking.Debug.Known_Tasks'Range loop + if System.Tasking.Debug.Known_Tasks (J) = null then + System.Tasking.Debug.Known_Tasks (J) := C; + C.Known_Tasks_Index := J; + exit; + end if; + end loop; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Activating, C); + end if; + + C.Common.State := Runnable; + Unlock (C); Unlock (P); @@ -1130,6 +1145,11 @@ package body System.Tasking.Stages is Self_ID.Deferral_Level := 0; end if; + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Run, Self_ID); + end if; + begin -- We are separating the following portion of the code in order to -- place the exception handlers in a different block. In this way, @@ -1168,8 +1188,18 @@ package body System.Tasking.Stages is if Self_ID.Terminate_Alternative then Cause := Normal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Terminated, Self_ID); + end if; else Cause := Abnormal; + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Abort_Terminated, Self_ID); + end if; end if; when others => -- ??? Using an E : others here causes CD2C11A to fail on Tru64 @@ -1194,7 +1224,13 @@ package body System.Tasking.Stages is -- procedure, as well as the associated Exception_Occurrence. Cause := Unhandled_Exception; + Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); + + if Global_Task_Debug_Event_Set then + Debug.Signal_Debug_Event + (Debug.Debug_Event_Exception_Terminated, Self_ID); + end if; end; -- Look for a task termination handler. This code is for all tasks but -- 2.30.2