|
111
|
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 -- --
|
|
145
|
9 -- Copyright (C) 1997-2019, Free Software Foundation, Inc. --
|
|
111
|
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 -- 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. --
|
|
|
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;
|
