mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 01:20:52 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
* 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
This commit is contained in:
Doug Rupp 2009-04-16 09:34:40 +00:00 committed by Arnaud Charlet
parent 205c14b0d0
commit 5e44c5eab4
17 changed files with 242 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
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.
2009-04-16 Thomas Quinot <quinot@adacore.com>
* sem_elim.adb: Minor reformatting

12
gcc/ada/s-taprop-hpux-dce.adb
View File

@ -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;
--------------

12
gcc/ada/s-taprop-irix.adb
View File

@ -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;
--------------

12
gcc/ada/s-taprop-linux.adb
View File

@ -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;

12
gcc/ada/s-taprop-mingw.adb
View File

@ -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;
--------------

12
gcc/ada/s-taprop-posix.adb
View File

@ -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;

12
gcc/ada/s-taprop-solaris.adb
View File

@ -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;
--------------

13
gcc/ada/s-taprop-tru64.adb
View File

@ -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;
end Enter_Task;
--------------

41
gcc/ada/s-taprop-vms.adb
View File

@ -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;

12
gcc/ada/s-taprop-vxworks.adb
View File

@ -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

12
gcc/ada/s-tasdeb.adb
View File

@ -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 --
--------------------

20
gcc/ada/s-tasdeb.ads
View File

@ -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 --
----------------------------------

122
gcc/ada/s-tasini.adb
View File

@ -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.
-- 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.
-- 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);

31
gcc/ada/s-taskin.adb
View File

@ -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

26
gcc/ada/s-taskin.ads
View File

@ -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;
---------------------------------------

10
gcc/ada/s-tasren.adb
View File

@ -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;

38
gcc/ada/s-tassta.adb
View File

@ -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