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-2013, 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
40with System.Address_Image;
41with System.CRTL;
42with System.Task_Primitives;
43with System.Task_Primitives.Operations;
44
45package body System.Tasking.Debug is
46
47   package STPO renames System.Task_Primitives.Operations;
48
49   type Trace_Flag_Set is array (Character) of Boolean;
50
51   Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
52
53   Stderr_Fd : constant := 2;
54   --  File descriptor for standard error
55
56   -----------------------
57   -- Local Subprograms --
58   -----------------------
59
60   procedure Write (Fd : Integer; S : String; Count : Integer);
61   --  Write Count characters of S to the file descriptor Fd
62
63   procedure Put (S : String);
64   --  Display S on standard error
65
66   procedure Put_Line (S : String := "");
67   --  Display S on standard error with an additional line terminator
68
69   function Task_Image (T : Task_Id) return String;
70   --  Return the relevant characters from T.Common.Task_Image
71
72   function Task_Id_Image (T : Task_Id) return String;
73   --  Return the address in hexadecimal form
74
75   ------------------------
76   -- Continue_All_Tasks --
77   ------------------------
78
79   procedure Continue_All_Tasks is
80      C : Task_Id;
81
82      Dummy : Boolean;
83      pragma Unreferenced (Dummy);
84
85   begin
86      STPO.Lock_RTS;
87
88      C := All_Tasks_List;
89      while C /= null loop
90         Dummy := STPO.Continue_Task (C);
91         C := C.Common.All_Tasks_Link;
92      end loop;
93
94      STPO.Unlock_RTS;
95   end Continue_All_Tasks;
96
97   --------------------
98   -- Get_User_State --
99   --------------------
100
101   function Get_User_State return Long_Integer is
102   begin
103      return STPO.Self.User_State;
104   end Get_User_State;
105
106   ----------------
107   -- List_Tasks --
108   ----------------
109
110   procedure List_Tasks is
111      C : Task_Id;
112   begin
113      C := All_Tasks_List;
114
115      while C /= null loop
116         Print_Task_Info (C);
117         C := C.Common.All_Tasks_Link;
118      end loop;
119   end List_Tasks;
120
121   ------------------------
122   -- Print_Current_Task --
123   ------------------------
124
125   procedure Print_Current_Task is
126   begin
127      Print_Task_Info (STPO.Self);
128   end Print_Current_Task;
129
130   ---------------------
131   -- Print_Task_Info --
132   ---------------------
133
134   procedure Print_Task_Info (T : Task_Id) is
135      Entry_Call : Entry_Call_Link;
136      Parent     : Task_Id;
137
138   begin
139      if T = null then
140         Put_Line ("null task");
141         return;
142      end if;
143
144      Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State));
145      Parent := T.Common.Parent;
146
147      if Parent = null then
148         Put (", parent: <none>");
149      else
150         Put (", parent: " & Task_Image (Parent));
151      end if;
152
153      Put (", prio:" & T.Common.Current_Priority'Img);
154
155      if not T.Callable then
156         Put (", not callable");
157      end if;
158
159      if T.Aborting then
160         Put (", aborting");
161      end if;
162
163      if T.Deferral_Level /= 0 then
164         Put (", abort deferred");
165      end if;
166
167      if T.Common.Call /= null then
168         Entry_Call := T.Common.Call;
169         Put (", serving:");
170
171         while Entry_Call /= null loop
172            Put (Task_Id_Image (Entry_Call.Self));
173            Entry_Call := Entry_Call.Acceptor_Prev_Call;
174         end loop;
175      end if;
176
177      if T.Open_Accepts /= null then
178         Put (", accepting:");
179
180         for J in T.Open_Accepts'Range loop
181            Put (T.Open_Accepts (J).S'Img);
182         end loop;
183
184         if T.Terminate_Alternative then
185            Put (" or terminate");
186         end if;
187      end if;
188
189      if T.User_State /= 0 then
190         Put (", state:" & T.User_State'Img);
191      end if;
192
193      Put_Line;
194   end Print_Task_Info;
195
196   ---------
197   -- Put --
198   ---------
199
200   procedure Put (S : String) is
201   begin
202      Write (Stderr_Fd, S, S'Length);
203   end Put;
204
205   --------------
206   -- Put_Line --
207   --------------
208
209   procedure Put_Line (S : String := "") is
210   begin
211      Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
212   end Put_Line;
213
214   ----------------------
215   -- Resume_All_Tasks --
216   ----------------------
217
218   procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
219      C     : Task_Id;
220      Dummy : Boolean;
221      pragma Unreferenced (Dummy);
222
223   begin
224      STPO.Lock_RTS;
225      C := All_Tasks_List;
226
227      while C /= null loop
228         Dummy := STPO.Resume_Task (C, Thread_Self);
229         C := C.Common.All_Tasks_Link;
230      end loop;
231
232      STPO.Unlock_RTS;
233   end Resume_All_Tasks;
234
235   ---------------
236   -- Set_Trace --
237   ---------------
238
239   procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
240   begin
241      Trace_On (Flag) := Value;
242   end Set_Trace;
243
244   --------------------
245   -- Set_User_State --
246   --------------------
247
248   procedure Set_User_State (Value : Long_Integer) is
249   begin
250      STPO.Self.User_State := Value;
251   end Set_User_State;
252
253   ------------------------
254   -- Signal_Debug_Event --
255   ------------------------
256
257   procedure Signal_Debug_Event
258     (Event_Kind : Event_Kind_Type;
259      Task_Value : Task_Id)
260   is
261   begin
262      null;
263   end Signal_Debug_Event;
264
265   --------------------
266   -- Stop_All_Tasks --
267   --------------------
268
269   procedure Stop_All_Tasks is
270      C : Task_Id;
271
272      Dummy : Boolean;
273      pragma Unreferenced (Dummy);
274
275   begin
276      STPO.Lock_RTS;
277
278      C := All_Tasks_List;
279      while C /= null loop
280         Dummy := STPO.Stop_Task (C);
281         C := C.Common.All_Tasks_Link;
282      end loop;
283
284      STPO.Unlock_RTS;
285   end Stop_All_Tasks;
286
287   ----------------------------
288   -- Stop_All_Tasks_Handler --
289   ----------------------------
290
291   procedure Stop_All_Tasks_Handler is
292   begin
293      STPO.Stop_All_Tasks;
294   end Stop_All_Tasks_Handler;
295
296   -----------------------
297   -- Suspend_All_Tasks --
298   -----------------------
299
300   procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
301      C     : Task_Id;
302      Dummy : Boolean;
303      pragma Unreferenced (Dummy);
304
305   begin
306      STPO.Lock_RTS;
307      C := All_Tasks_List;
308
309      while C /= null loop
310         Dummy := STPO.Suspend_Task (C, Thread_Self);
311         C := C.Common.All_Tasks_Link;
312      end loop;
313
314      STPO.Unlock_RTS;
315   end Suspend_All_Tasks;
316
317   ------------------------
318   -- Task_Creation_Hook --
319   ------------------------
320
321   procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
322      pragma Inspection_Point (Thread);
323      --  gdb needs to access the thread parameter in order to implement
324      --  the multitask mode under VxWorks.
325
326   begin
327      null;
328   end Task_Creation_Hook;
329
330   ----------------
331   -- Task_Id_Image --
332   ----------------
333
334   function Task_Id_Image (T : Task_Id) return String is
335   begin
336      if T = null then
337         return "Null_Task_Id";
338      else
339         return Address_Image (T.all'Address);
340      end if;
341   end Task_Id_Image;
342
343   ----------------
344   -- Task_Image --
345   ----------------
346
347   function Task_Image (T : Task_Id) return String is
348   begin
349      --  In case T.Common.Task_Image_Len is uninitialized junk, we check that
350      --  it is in range, to make this more robust.
351
352      if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
353         return T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
354      else
355         return T.Common.Task_Image;
356      end if;
357   end Task_Image;
358
359   ---------------------------
360   -- Task_Termination_Hook --
361   ---------------------------
362
363   procedure Task_Termination_Hook is
364   begin
365      null;
366   end Task_Termination_Hook;
367
368   -----------
369   -- Trace --
370   -----------
371
372   procedure Trace
373     (Self_Id  : Task_Id;
374      Msg      : String;
375      Flag     : Character;
376      Other_Id : Task_Id := null)
377   is
378   begin
379      if Trace_On (Flag) then
380         Put (Task_Id_Image (Self_Id) &
381              ':' & Flag & ':' &
382              Task_Image (Self_Id) &
383              ':');
384
385         if Other_Id /= null then
386            Put (Task_Id_Image (Other_Id) & ':');
387         end if;
388
389         Put_Line (Msg);
390      end if;
391   end Trace;
392
393   -----------
394   -- Write --
395   -----------
396
397   procedure Write (Fd : Integer; S : String; Count : Integer) is
398      Discard : System.CRTL.ssize_t;
399      pragma Unreferenced (Discard);
400   begin
401      Discard := System.CRTL.write (Fd, S'Address,
402                                    System.CRTL.size_t (Count));
403      --  Ignore write errors here; this is just debugging output, and there's
404      --  nothing to be done about errors anyway.
405   end Write;
406
407end System.Tasking.Debug;
408