with System.CRTL;
with System.Task_Primitives.Operations;
with Unchecked_Conversion;
package body System.Tasking.Debug is
package STPO renames System.Task_Primitives.Operations;
function To_Integer is new
Unchecked_Conversion (Task_Id, System.Address);
type Trace_Flag_Set is array (Character) of Boolean;
Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
procedure Write (Fd : Integer; S : String; Count : Integer);
procedure Put (S : String);
procedure Put_Line (S : String := "");
function Get_User_State return Long_Integer is
begin
return STPO.Self.User_State;
end Get_User_State;
procedure List_Tasks is
C : Task_Id;
begin
C := All_Tasks_List;
while C /= null loop
Print_Task_Info (C);
C := C.Common.All_Tasks_Link;
end loop;
end List_Tasks;
procedure Print_Current_Task is
begin
Print_Task_Info (STPO.Self);
end Print_Current_Task;
procedure Print_Task_Info (T : Task_Id) is
Entry_Call : Entry_Call_Link;
Parent : Task_Id;
begin
if T = null then
Put_Line ("null task");
return;
end if;
Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
Task_States'Image (T.Common.State));
Parent := T.Common.Parent;
if Parent = null then
Put (", parent: <none>");
else
Put (", parent: " &
Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
end if;
Put (", prio:" & T.Common.Current_Priority'Img);
if not T.Callable then
Put (", not callable");
end if;
if T.Aborting then
Put (", aborting");
end if;
if T.Deferral_Level /= 0 then
Put (", abort deferred");
end if;
if T.Common.Call /= null then
Entry_Call := T.Common.Call;
Put (", serving:");
while Entry_Call /= null loop
Put (To_Integer (Entry_Call.Self)'Img);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
end if;
if T.Open_Accepts /= null then
Put (", accepting:");
for J in T.Open_Accepts'Range loop
Put (T.Open_Accepts (J).S'Img);
end loop;
if T.Terminate_Alternative then
Put (" or terminate");
end if;
end if;
if T.User_State /= 0 then
Put (", state:" & T.User_State'Img);
end if;
Put_Line;
end Print_Task_Info;
procedure Put (S : String) is
begin
Write (2, S, S'Length);
end Put;
procedure Put_Line (S : String := "") is
begin
Write (2, S & ASCII.LF, S'Length + 1);
end Put_Line;
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
begin
STPO.Lock_RTS;
C := All_Tasks_List;
while C /= null loop
Dummy := STPO.Resume_Task (C, Thread_Self);
C := C.Common.All_Tasks_Link;
end loop;
STPO.Unlock_RTS;
end Resume_All_Tasks;
procedure Set_Trace (Flag : Character; Value : Boolean := True) is
begin
Trace_On (Flag) := Value;
end Set_Trace;
procedure Set_User_State (Value : Long_Integer) is
begin
STPO.Self.User_State := Value;
end Set_User_State;
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
begin
STPO.Lock_RTS;
C := All_Tasks_List;
while C /= null loop
Dummy := STPO.Suspend_Task (C, Thread_Self);
C := C.Common.All_Tasks_Link;
end loop;
STPO.Unlock_RTS;
end Suspend_All_Tasks;
procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
pragma Inspection_Point (Thread);
begin
null;
end Task_Creation_Hook;
procedure Task_Termination_Hook is
begin
null;
end Task_Termination_Hook;
procedure Trace
(Self_Id : Task_Id;
Msg : String;
Flag : Character;
Other_Id : Task_Id := null)
is
begin
if Trace_On (Flag) then
Put (To_Integer (Self_Id)'Img &
':' & Flag & ':' &
Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
':');
if Other_Id /= null then
Put (To_Integer (Other_Id)'Img & ':');
end if;
Put_Line (Msg);
end if;
end Trace;
procedure Write (Fd : Integer; S : String; Count : Integer) is
Discard : Integer;
pragma Unreferenced (Discard);
begin
Discard := System.CRTL.write (Fd, S (S'First)'Address, Count);
end Write;
end System.Tasking.Debug;