1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . D E B U G --
9 -- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This package encapsulates all direct interfaces to task debugging services
33 -- that are needed by gdb with gnat mode.
35 -- Note : This file *must* be compiled with debugging information
37 -- Do not add any dependency to GNARL packages since this package is used
38 -- in both normal and restricted (ravenscar) environments.
41 with System
.Task_Primitives
;
42 with System
.Task_Primitives
.Operations
;
43 with Ada
.Unchecked_Conversion
;
45 package body System
.Tasking
.Debug
is
47 package STPO
renames System
.Task_Primitives
.Operations
;
49 function To_Integer
is new
50 Ada
.Unchecked_Conversion
(Task_Id
, System
.Task_Primitives
.Task_Address
);
52 type Trace_Flag_Set
is array (Character) of Boolean;
54 Trace_On
: Trace_Flag_Set
:= ('A' .. 'Z' => False, others => True);
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
60 procedure Write
(Fd
: Integer; S
: String; Count
: Integer);
62 procedure Put
(S
: String);
63 -- Display S on standard output
65 procedure Put_Line
(S
: String := "");
66 -- Display S on standard output with an additional line terminator
68 ------------------------
69 -- Continue_All_Tasks --
70 ------------------------
72 procedure Continue_All_Tasks
is
76 pragma Unreferenced
(Dummy
);
83 Dummy
:= STPO
.Continue_Task
(C
);
84 C
:= C
.Common
.All_Tasks_Link
;
88 end Continue_All_Tasks
;
94 function Get_User_State
return Long_Integer is
96 return STPO
.Self
.User_State
;
103 procedure List_Tasks
is
110 C
:= C
.Common
.All_Tasks_Link
;
114 ------------------------
115 -- Print_Current_Task --
116 ------------------------
118 procedure Print_Current_Task
is
120 Print_Task_Info
(STPO
.Self
);
121 end Print_Current_Task
;
123 ---------------------
124 -- Print_Task_Info --
125 ---------------------
127 procedure Print_Task_Info
(T
: Task_Id
) is
128 Entry_Call
: Entry_Call_Link
;
133 Put_Line
("null task");
137 Put
(T
.Common
.Task_Image
(1 .. T
.Common
.Task_Image_Len
) & ": " &
138 Task_States
'Image (T
.Common
.State
));
140 Parent
:= T
.Common
.Parent
;
142 if Parent
= null then
143 Put
(", parent: <none>");
146 Parent
.Common
.Task_Image
(1 .. Parent
.Common
.Task_Image_Len
));
149 Put
(", prio:" & T
.Common
.Current_Priority
'Img);
151 if not T
.Callable
then
152 Put
(", not callable");
159 if T
.Deferral_Level
/= 0 then
160 Put
(", abort deferred");
163 if T
.Common
.Call
/= null then
164 Entry_Call
:= T
.Common
.Call
;
167 while Entry_Call
/= null loop
168 Put
(To_Integer
(Entry_Call
.Self
)'Img);
169 Entry_Call
:= Entry_Call
.Acceptor_Prev_Call
;
173 if T
.Open_Accepts
/= null then
174 Put
(", accepting:");
176 for J
in T
.Open_Accepts
'Range loop
177 Put
(T
.Open_Accepts
(J
).S
'Img);
180 if T
.Terminate_Alternative
then
181 Put
(" or terminate");
185 if T
.User_State
/= 0 then
186 Put
(", state:" & T
.User_State
'Img);
196 procedure Put
(S
: String) is
198 Write
(2, S
, S
'Length);
205 procedure Put_Line
(S
: String := "") is
207 Write
(2, S
& ASCII
.LF
, S
'Length + 1);
210 ----------------------
211 -- Resume_All_Tasks --
212 ----------------------
214 procedure Resume_All_Tasks
(Thread_Self
: OS_Interface
.Thread_Id
) is
217 pragma Unreferenced
(Dummy
);
224 Dummy
:= STPO
.Resume_Task
(C
, Thread_Self
);
225 C
:= C
.Common
.All_Tasks_Link
;
229 end Resume_All_Tasks
;
235 procedure Set_Trace
(Flag
: Character; Value
: Boolean := True) is
237 Trace_On
(Flag
) := Value
;
244 procedure Set_User_State
(Value
: Long_Integer) is
246 STPO
.Self
.User_State
:= Value
;
249 ------------------------
250 -- Signal_Debug_Event --
251 ------------------------
253 procedure Signal_Debug_Event
254 (Event_Kind
: Event_Kind_Type
;
255 Task_Value
: Task_Id
)
259 end Signal_Debug_Event
;
265 procedure Stop_All_Tasks
is
269 pragma Unreferenced
(Dummy
);
276 Dummy
:= STPO
.Stop_Task
(C
);
277 C
:= C
.Common
.All_Tasks_Link
;
283 ----------------------------
284 -- Stop_All_Tasks_Handler --
285 ----------------------------
287 procedure Stop_All_Tasks_Handler
is
290 end Stop_All_Tasks_Handler
;
292 -----------------------
293 -- Suspend_All_Tasks --
294 -----------------------
296 procedure Suspend_All_Tasks
(Thread_Self
: OS_Interface
.Thread_Id
) is
299 pragma Unreferenced
(Dummy
);
306 Dummy
:= STPO
.Suspend_Task
(C
, Thread_Self
);
307 C
:= C
.Common
.All_Tasks_Link
;
311 end Suspend_All_Tasks
;
313 ------------------------
314 -- Task_Creation_Hook --
315 ------------------------
317 procedure Task_Creation_Hook
(Thread
: OS_Interface
.Thread_Id
) is
318 pragma Inspection_Point
(Thread
);
319 -- gdb needs to access the thread parameter in order to implement
320 -- the multitask mode under VxWorks.
324 end Task_Creation_Hook
;
326 ---------------------------
327 -- Task_Termination_Hook --
328 ---------------------------
330 procedure Task_Termination_Hook
is
333 end Task_Termination_Hook
;
343 Other_Id
: Task_Id
:= null)
346 if Trace_On
(Flag
) then
347 Put
(To_Integer
(Self_Id
)'Img &
349 Self_Id
.Common
.Task_Image
(1 .. Self_Id
.Common
.Task_Image_Len
) &
352 if Other_Id
/= null then
353 Put
(To_Integer
(Other_Id
)'Img & ':');
364 procedure Write
(Fd
: Integer; S
: String; Count
: Integer) is
365 Discard
: System
.CRTL
.ssize_t
;
366 pragma Unreferenced
(Discard
);
368 Discard
:= System
.CRTL
.write
(Fd
, S
(S
'First)'Address,
369 System
.CRTL
.size_t
(Count
));
370 -- Is it really right to ignore write errors here ???
373 end System
.Tasking
.Debug
;