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