File : s-tasdeb.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G . D E B U G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1997-2014, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This package encapsulates all direct interfaces to task debugging services
33 -- that are needed by gdb with gnat mode.
34
35 -- Note : This file *must* be compiled with debugging information
36
37 -- Do not add any dependency to GNARL packages since this package is used
38 -- in both normal and restricted (ravenscar) environments.
39
40 pragma Restriction_Warnings (No_Secondary_Stack);
41 -- We wish to avoid secondary stack usage here, because (e.g.) Trace is called
42 -- at delicate times, such as during task termination after the secondary
43 -- stack has been deallocated. It's just a warning, so we don't require
44 -- partition-wide consistency.
45
46 with System.CRTL;
47 with System.Storage_Elements; use System.Storage_Elements;
48 with System.Task_Primitives;
49 with System.Task_Primitives.Operations;
50
51 package body System.Tasking.Debug is
52
53 package STPO renames System.Task_Primitives.Operations;
54
55 type Trace_Flag_Set is array (Character) of Boolean;
56
57 Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
58
59 Stderr_Fd : constant := 2;
60 -- File descriptor for standard error
61
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
65
66 procedure Write (Fd : Integer; S : String; Count : Integer);
67 -- Write Count characters of S to the file descriptor Fd
68
69 procedure Put (S : String);
70 -- Display S on standard error
71
72 procedure Put_Line (S : String := "");
73 -- Display S on standard error with an additional line terminator
74
75 procedure Put_Task_Image (T : Task_Id);
76 -- Display relevant characters from T.Common.Task_Image on standard error
77
78 procedure Put_Task_Id_Image (T : Task_Id);
79 -- Display address in hexadecimal form on standard error
80
81 ------------------------
82 -- Continue_All_Tasks --
83 ------------------------
84
85 procedure Continue_All_Tasks is
86 C : Task_Id;
87 Dummy : Boolean;
88
89 begin
90 STPO.Lock_RTS;
91
92 C := All_Tasks_List;
93 while C /= null loop
94 Dummy := STPO.Continue_Task (C);
95 C := C.Common.All_Tasks_Link;
96 end loop;
97
98 STPO.Unlock_RTS;
99 end Continue_All_Tasks;
100
101 --------------------
102 -- Get_User_State --
103 --------------------
104
105 function Get_User_State return Long_Integer is
106 begin
107 return STPO.Self.User_State;
108 end Get_User_State;
109
110 ----------------
111 -- List_Tasks --
112 ----------------
113
114 procedure List_Tasks is
115 C : Task_Id;
116 begin
117 C := All_Tasks_List;
118 while C /= null loop
119 Print_Task_Info (C);
120 C := C.Common.All_Tasks_Link;
121 end loop;
122 end List_Tasks;
123
124 ------------------------
125 -- Print_Current_Task --
126 ------------------------
127
128 procedure Print_Current_Task is
129 begin
130 Print_Task_Info (STPO.Self);
131 end Print_Current_Task;
132
133 ---------------------
134 -- Print_Task_Info --
135 ---------------------
136
137 procedure Print_Task_Info (T : Task_Id) is
138 Entry_Call : Entry_Call_Link;
139 Parent : Task_Id;
140
141 begin
142 if T = null then
143 Put_Line ("null task");
144 return;
145 end if;
146
147 Put_Task_Image (T);
148 Put (": " & Task_States'Image (T.Common.State));
149 Parent := T.Common.Parent;
150
151 if Parent = null then
152 Put (", parent: <none>");
153 else
154 Put (", parent: ");
155 Put_Task_Image (Parent);
156 end if;
157
158 Put (", prio:" & T.Common.Current_Priority'Img);
159
160 if not T.Callable then
161 Put (", not callable");
162 end if;
163
164 if T.Aborting then
165 Put (", aborting");
166 end if;
167
168 if T.Deferral_Level /= 0 then
169 Put (", abort deferred");
170 end if;
171
172 if T.Common.Call /= null then
173 Entry_Call := T.Common.Call;
174 Put (", serving:");
175
176 while Entry_Call /= null loop
177 Put_Task_Id_Image (Entry_Call.Self);
178 Entry_Call := Entry_Call.Acceptor_Prev_Call;
179 end loop;
180 end if;
181
182 if T.Open_Accepts /= null then
183 Put (", accepting:");
184
185 for J in T.Open_Accepts'Range loop
186 Put (T.Open_Accepts (J).S'Img);
187 end loop;
188
189 if T.Terminate_Alternative then
190 Put (" or terminate");
191 end if;
192 end if;
193
194 if T.User_State /= 0 then
195 Put (", state:" & T.User_State'Img);
196 end if;
197
198 Put_Line;
199 end Print_Task_Info;
200
201 ---------
202 -- Put --
203 ---------
204
205 procedure Put (S : String) is
206 begin
207 Write (Stderr_Fd, S, S'Length);
208 end Put;
209
210 --------------
211 -- Put_Line --
212 --------------
213
214 procedure Put_Line (S : String := "") is
215 begin
216 Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
217 end Put_Line;
218
219 -----------------------
220 -- Put_Task_Id_Image --
221 -----------------------
222
223 procedure Put_Task_Id_Image (T : Task_Id) is
224 Address_Image_Length : constant :=
225 13 + (if Standard'Address_Size = 64 then 10 else 0);
226 -- Length of string to be printed for address of task
227
228 H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
229 -- Table of hex digits
230
231 S : String (1 .. Address_Image_Length);
232 P : Natural;
233 N : Integer_Address;
234 U : Natural := 0;
235
236 begin
237 if T = null then
238 Put ("Null_Task_Id");
239
240 else
241 S (S'Last) := '#';
242 P := Address_Image_Length - 1;
243 N := To_Integer (T.all'Address);
244 while P > 3 loop
245 if U = 4 then
246 S (P) := '_';
247 P := P - 1;
248 U := 1;
249 else
250 U := U + 1;
251 end if;
252
253 S (P) := H (Integer (N mod 16));
254 P := P - 1;
255 N := N / 16;
256 end loop;
257
258 S (1 .. 3) := "16#";
259 Put (S);
260 end if;
261 end Put_Task_Id_Image;
262
263 --------------------
264 -- Put_Task_Image --
265 --------------------
266
267 procedure Put_Task_Image (T : Task_Id) is
268 begin
269 -- In case T.Common.Task_Image_Len is uninitialized junk, we check that
270 -- it is in range, to make this more robust.
271
272 if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
273 Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
274 else
275 Put (T.Common.Task_Image);
276 end if;
277 end Put_Task_Image;
278
279 ----------------------
280 -- Resume_All_Tasks --
281 ----------------------
282
283 procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
284 C : Task_Id;
285 Dummy : Boolean;
286
287 begin
288 STPO.Lock_RTS;
289
290 C := All_Tasks_List;
291 while C /= null loop
292 Dummy := STPO.Resume_Task (C, Thread_Self);
293 C := C.Common.All_Tasks_Link;
294 end loop;
295
296 STPO.Unlock_RTS;
297 end Resume_All_Tasks;
298
299 ---------------
300 -- Set_Trace --
301 ---------------
302
303 procedure Set_Trace (Flag : Character; Value : Boolean := True) is
304 begin
305 Trace_On (Flag) := Value;
306 end Set_Trace;
307
308 --------------------
309 -- Set_User_State --
310 --------------------
311
312 procedure Set_User_State (Value : Long_Integer) is
313 begin
314 STPO.Self.User_State := Value;
315 end Set_User_State;
316
317 ------------------------
318 -- Signal_Debug_Event --
319 ------------------------
320
321 procedure Signal_Debug_Event
322 (Event_Kind : Event_Kind_Type;
323 Task_Value : Task_Id)
324 is
325 begin
326 null;
327 end Signal_Debug_Event;
328
329 --------------------
330 -- Stop_All_Tasks --
331 --------------------
332
333 procedure Stop_All_Tasks is
334 C : Task_Id;
335 Dummy : Boolean;
336
337 begin
338 STPO.Lock_RTS;
339
340 C := All_Tasks_List;
341 while C /= null loop
342 Dummy := STPO.Stop_Task (C);
343 C := C.Common.All_Tasks_Link;
344 end loop;
345
346 STPO.Unlock_RTS;
347 end Stop_All_Tasks;
348
349 ----------------------------
350 -- Stop_All_Tasks_Handler --
351 ----------------------------
352
353 procedure Stop_All_Tasks_Handler is
354 begin
355 STPO.Stop_All_Tasks;
356 end Stop_All_Tasks_Handler;
357
358 -----------------------
359 -- Suspend_All_Tasks --
360 -----------------------
361
362 procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
363 C : Task_Id;
364 Dummy : Boolean;
365
366 begin
367 STPO.Lock_RTS;
368
369 C := All_Tasks_List;
370 while C /= null loop
371 Dummy := STPO.Suspend_Task (C, Thread_Self);
372 C := C.Common.All_Tasks_Link;
373 end loop;
374
375 STPO.Unlock_RTS;
376 end Suspend_All_Tasks;
377
378 ------------------------
379 -- Task_Creation_Hook --
380 ------------------------
381
382 procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
383 pragma Inspection_Point (Thread);
384 -- gdb needs to access the thread parameter in order to implement
385 -- the multitask mode under VxWorks.
386
387 begin
388 null;
389 end Task_Creation_Hook;
390
391 ---------------------------
392 -- Task_Termination_Hook --
393 ---------------------------
394
395 procedure Task_Termination_Hook is
396 begin
397 null;
398 end Task_Termination_Hook;
399
400 -----------
401 -- Trace --
402 -----------
403
404 procedure Trace
405 (Self_Id : Task_Id;
406 Msg : String;
407 Flag : Character;
408 Other_Id : Task_Id := null)
409 is
410 begin
411 if Trace_On (Flag) then
412 Put_Task_Id_Image (Self_Id);
413 Put (":" & Flag & ":");
414 Put_Task_Image (Self_Id);
415 Put (":");
416
417 if Other_Id /= null then
418 Put_Task_Id_Image (Other_Id);
419 Put (":");
420 end if;
421
422 Put_Line (Msg);
423 end if;
424 end Trace;
425
426 -----------
427 -- Write --
428 -----------
429
430 procedure Write (Fd : Integer; S : String; Count : Integer) is
431 Discard : System.CRTL.ssize_t;
432 -- Ignore write errors here; this is just debugging output, and there's
433 -- nothing to be done about errors anyway.
434 begin
435 Discard :=
436 System.CRTL.write
437 (Fd, S'Address, System.CRTL.size_t (Count));
438 end Write;
439
440 -----------------
441 -- Master_Hook --
442 -----------------
443
444 procedure Master_Hook
445 (Dependent : Task_Id;
446 Parent : Task_Id;
447 Master_Level : Integer)
448 is
449 pragma Inspection_Point (Dependent);
450 pragma Inspection_Point (Parent);
451 pragma Inspection_Point (Master_Level);
452 begin
453 null;
454 end Master_Hook;
455
456 ---------------------------
457 -- Master_Completed_Hook --
458 ---------------------------
459
460 procedure Master_Completed_Hook
461 (Self_ID : Task_Id;
462 Master_Level : Integer)
463 is
464 pragma Inspection_Point (Self_ID);
465 pragma Inspection_Point (Master_Level);
466 begin
467 null;
468 end Master_Completed_Hook;
469
470 end System.Tasking.Debug;