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-2019, 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-- 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
40pragma 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
46with System.CRTL;
47with System.Storage_Elements; use System.Storage_Elements;
48with System.Task_Primitives;
49with System.Task_Primitives.Operations;
50
51package 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
470end System.Tasking.Debug;
471