1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . D E B U G --
10 -- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This package encapsulates all direct interfaces to task debugging services
36 -- that are needed by gdb with gnat mode (1.13 and higher)
38 -- Note : This file *must* be compiled with debugging information
40 -- Do not add any dependency to GNARL packages since this package is used
41 -- in both normal and restricted (ravenscar) environments.
43 with System.Task_Info,
44 System.Task_Primitives.Operations,
47 package body System.Tasking.Debug is
51 package STPO renames System.Task_Primitives.Operations;
53 type Integer_Address is mod 2 ** Standard'Address_Size;
56 Unchecked_Conversion (Task_ID, Integer_Address);
58 Hex_Address_Width : constant := (Standard'Address_Size / 4);
60 Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character :=
63 subtype Buf_Range is Integer range 1 .. 80;
64 type Buf_Array is array (Buf_Range) of aliased Character;
67 Next : Buf_Range := Buf_Range'First;
68 Chars : Buf_Array := (Buf_Range => ' ');
71 type Buffer_Ptr is access all Buffer;
73 type Trace_Flag_Set is array (Character) of Boolean;
75 Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
85 -- Put TCB pointer T, (coded in hexadecimal) into Buffer
86 -- right-justified in Width characters.
92 -- Put N (coded in decimal) into Buf right-justified in Width
93 -- characters starting at Buf (Next).
99 -- Put string S into Buf left-justified in Width characters
100 -- starting with space in Buf (Next), truncated as necessary.
104 Buffer : Buffer_Ptr);
105 -- Put character C into Buf, left-justified, starting at Buf (Next)
107 procedure Space (Buffer : Buffer_Ptr);
108 -- Increment Next, resulting in a space
112 Buffer : Buffer_Ptr);
113 -- Increment Next by N, resulting in N spaces
115 procedure Clear (Buffer : Buffer_Ptr);
116 -- Clear Buf and reset Next to 1
118 procedure Write_Buf (Buffer : Buffer_Ptr);
119 -- Write contents of Buf (1 .. Next) to standard output
125 procedure Clear (Buffer : Buffer_Ptr) is
126 Next : Buf_Range renames Buffer.Next;
127 Buf : Buf_Array renames Buffer.Chars;
130 Buf := (Buf_Range => ' ');
138 function Image (T : ST.Task_ID) return String is
139 Buf : aliased Buffer;
140 Result : String (1 .. Hex_Address_Width + 21);
142 use type System.Task_Info.Task_Image_Type;
145 Clear (Buf'Unchecked_Access);
146 Put (T, Hex_Address_Width, Buf'Unchecked_Access);
147 Put (':', Buf'Unchecked_Access);
148 Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
149 Space (Buf'Unchecked_Access);
151 if T.Common.Task_Image = null then
152 Put ("", 15, Buf'Unchecked_Access);
154 Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
157 for J in Result'Range loop
158 Result (J) := Buf.Chars (J);
168 procedure List_Tasks is
172 Print_Task_Info_Header;
177 C := C.Common.All_Tasks_Link;
181 -----------------------
182 -- Print_Accept_Info --
183 -----------------------
185 procedure Print_Accept_Info (T : ST.Task_ID) is
186 Buf : aliased Buffer;
189 if T.Open_Accepts = null then
193 Clear (Buf'Unchecked_Access);
194 Space (10, Buf'Unchecked_Access);
195 Put ("accepting:", 11, Buf'Unchecked_Access);
197 for J in T.Open_Accepts.all'Range loop
198 Put (Integer_Address (T.Open_Accepts (J).S), 3, Buf'Unchecked_Access);
201 Write_Buf (Buf'Unchecked_Access);
202 end Print_Accept_Info;
204 ------------------------
205 -- Print_Current_Task --
206 ------------------------
208 procedure Print_Current_Task is
210 Print_Task_Info (STPO.Self);
211 end Print_Current_Task;
213 ---------------------
214 -- Print_Task_Info --
215 ---------------------
217 procedure Print_Task_Info (T : ST.Task_ID) is
218 Entry_Call : Entry_Call_Link;
219 Buf : aliased Buffer;
221 use type System.Task_Info.Task_Image_Type;
224 Clear (Buf'Unchecked_Access);
225 Put (T, Hex_Address_Width, Buf'Unchecked_Access);
226 Put (':', Buf'Unchecked_Access);
227 Put (' ', Buf'Unchecked_Access);
228 Put (':', Buf'Unchecked_Access);
231 Put (" null task", 10, Buf'Unchecked_Access);
232 Write_Buf (Buf'Unchecked_Access);
236 Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
237 Space (Buf'Unchecked_Access);
239 if T.Common.Task_Image = null then
240 Put ("", 15, Buf'Unchecked_Access);
242 Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
245 Space (Buf'Unchecked_Access);
246 Put (Task_States'Image (T.Common.State), 10, Buf'Unchecked_Access);
247 Space (Buf'Unchecked_Access);
250 Put ('C', Buf'Unchecked_Access);
252 Space (Buf'Unchecked_Access);
255 if T.Open_Accepts /= null then
256 Put ('A', Buf'Unchecked_Access);
258 Space (Buf'Unchecked_Access);
261 if T.Common.Call /= null then
262 Put ('C', Buf'Unchecked_Access);
264 Space (Buf'Unchecked_Access);
267 if T.Terminate_Alternative then
268 Put ('T', Buf'Unchecked_Access);
270 Space (Buf'Unchecked_Access);
274 Put ('A', Buf'Unchecked_Access);
276 Space (Buf'Unchecked_Access);
279 if T.Deferral_Level = 0 then
280 Space (3, Buf'Unchecked_Access);
282 Put ('D', Buf'Unchecked_Access);
283 if T.Deferral_Level < 0 then
284 Put ("<0", 2, Buf'Unchecked_Access);
285 elsif T.Deferral_Level > 1 then
286 Put (Integer_Address (T.Deferral_Level), 2, Buf'Unchecked_Access);
288 Space (2, Buf'Unchecked_Access);
292 Space (Buf'Unchecked_Access);
293 Put (Integer_Address (T.Master_of_Task), 1, Buf'Unchecked_Access);
294 Space (Buf'Unchecked_Access);
295 Put (Integer_Address (T.Master_Within), 1, Buf'Unchecked_Access);
296 Put (',', Buf'Unchecked_Access);
297 Space (Buf'Unchecked_Access);
298 Put (Integer_Address (T.Awake_Count), 1, Buf'Unchecked_Access);
299 Space (Buf'Unchecked_Access);
300 Put (Integer_Address (T.Alive_Count), 1, Buf'Unchecked_Access);
301 Put (',', Buf'Unchecked_Access);
302 Space (Buf'Unchecked_Access);
303 Put (Integer_Address (T.ATC_Nesting_Level), 1, Buf'Unchecked_Access);
304 Space (Buf'Unchecked_Access);
305 Put (Integer_Address (T.Pending_ATC_Level), 1, Buf'Unchecked_Access);
306 Put (',', Buf'Unchecked_Access);
307 Space (Buf'Unchecked_Access);
308 Put (Integer_Address (T.Common.Wait_Count), 1, Buf'Unchecked_Access);
309 Put (',', Buf'Unchecked_Access);
310 Space (Buf'Unchecked_Access);
311 Put (Integer_Address (T.User_State), 1, Buf'Unchecked_Access);
312 Write_Buf (Buf'Unchecked_Access);
314 if T.Common.Call /= null then
315 Entry_Call := T.Common.Call;
316 Clear (Buf'Unchecked_Access);
317 Space (10, Buf'Unchecked_Access);
318 Put ("serving:", 8, Buf'Unchecked_Access);
320 while Entry_Call /= null loop
322 (Entry_Call.Self.Serial_Number), 5, Buf'Unchecked_Access);
323 Entry_Call := Entry_Call.Acceptor_Prev_Call;
326 Write_Buf (Buf'Unchecked_Access);
329 Print_Accept_Info (T);
332 ----------------------------
333 -- Print_Task_Info_Header --
334 ----------------------------
336 procedure Print_Task_Info_Header is
337 Buf : aliased Buffer;
340 Clear (Buf'Unchecked_Access);
341 Put ("TASK_ID", Hex_Address_Width, Buf'Unchecked_Access);
342 Put (':', Buf'Unchecked_Access);
343 Put ('F', Buf'Unchecked_Access);
344 Put (':', Buf'Unchecked_Access);
345 Put ("SERIAL_NUMBER", 4, Buf'Unchecked_Access);
346 Space (Buf'Unchecked_Access);
347 Put (" NAME", 15, Buf'Unchecked_Access);
348 Put (" STATE", 10, Buf'Unchecked_Access);
349 Space (11, Buf'Unchecked_Access);
350 Put ("MAST", 5, Buf'Unchecked_Access);
351 Put ("AWAK", 5, Buf'Unchecked_Access);
352 Put ("ATC", 5, Buf'Unchecked_Access);
353 Put ("WT", 3, Buf'Unchecked_Access);
354 Put ("DBG", 3, Buf'Unchecked_Access);
355 Write_Buf (Buf'Unchecked_Access);
356 end Print_Task_Info_Header;
368 X : Integer_Address := +T;
369 Next : Buf_Range renames Buffer.Next;
370 Buf : Buf_Array renames Buffer.Chars;
371 First : constant Integer := Next;
372 Wdth : Integer := Width;
375 if Wdth > Buf'Last - Next then
376 Wdth := Buf'Last - Next;
379 J := Next + (Wdth - 1);
386 Buf (J) := Hex_Digits (X rem 16);
390 -- Check for overflow
392 if J < First and then X > 0 then
404 (N : Integer_Address;
409 X : Integer_Address := N;
410 Next : Buf_Range renames Buffer.Next;
411 Buf : Buf_Array renames Buffer.Chars;
412 First : constant Integer := Next;
413 Wdth : Integer := Width;
416 if Wdth > Buf'Last - Next then
417 Wdth := Buf'Last - Next;
420 J := Next + (Wdth - 1);
427 Buf (J) := Hex_Digits (X rem 10);
431 -- Check for overflow
433 if J < First and then X > 0 then
448 Next : Buf_Range renames Buffer.Next;
449 Buf : Buf_Array renames Buffer.Chars;
450 Bound : constant Integer := Integer'Min (Next + Width, Buf'Last);
454 for K in S'Range loop
474 Next : Buf_Range renames Buffer.Next;
475 Buf : Buf_Array renames Buffer.Chars;
478 if Next >= Buf'Last then
480 else Buf (Next) := C;
485 ----------------------
486 -- Resume_All_Tasks --
487 ----------------------
489 procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
498 R := STPO.Resume_Task (C, Thread_Self);
499 C := C.Common.All_Tasks_Link;
503 end Resume_All_Tasks;
509 function Self return Task_ID is
520 Value : Boolean := True)
523 Trace_On (Flag) := Value;
530 procedure Set_User_State (Value : Integer) is
532 STPO.Self.User_State := Value;
539 procedure Space (Buffer : Buffer_Ptr) is
540 Next : Buf_Range renames Buffer.Next;
541 Buf : Buf_Array renames Buffer.Chars;
544 if Next >= Buf'Last then
555 Next : Buf_Range renames Buffer.Next;
556 Buf : Buf_Array renames Buffer.Chars;
559 if Next + N > Buf'Last then
566 -----------------------
567 -- Suspend_All_Tasks --
568 -----------------------
570 procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
579 R := STPO.Suspend_Task (C, Thread_Self);
580 C := C.Common.All_Tasks_Link;
584 end Suspend_All_Tasks;
586 ------------------------
587 -- Task_Creation_Hook --
588 ------------------------
590 procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
591 pragma Inspection_Point (Thread);
592 -- gdb needs to access the thread parameter in order to implement
593 -- the multitask mode under VxWorks.
597 end Task_Creation_Hook;
599 ---------------------------
600 -- Task_Termination_Hook --
601 ---------------------------
603 procedure Task_Termination_Hook is
606 end Task_Termination_Hook;
613 (Self_ID : ST.Task_ID;
615 Other_ID : ST.Task_ID;
618 Buf : aliased Buffer;
619 use type System.Task_Info.Task_Image_Type;
622 if Trace_On (Flag) then
623 Clear (Buf'Unchecked_Access);
624 Put (Self_ID, Hex_Address_Width, Buf'Unchecked_Access);
625 Put (':', Buf'Unchecked_Access);
626 Put (Flag, Buf'Unchecked_Access);
627 Put (':', Buf'Unchecked_Access);
629 (Integer_Address (Self_ID.Serial_Number),
630 4, Buf'Unchecked_Access);
631 Space (Buf'Unchecked_Access);
633 if Self_ID.Common.Task_Image = null then
634 Put ("", 15, Buf'Unchecked_Access);
636 Put (Self_ID.Common.Task_Image.all, 15, Buf'Unchecked_Access);
639 Space (Buf'Unchecked_Access);
641 if Other_ID /= null then
643 (Integer_Address (Other_ID.Serial_Number),
644 4, Buf'Unchecked_Access);
645 Space (Buf'Unchecked_Access);
648 Put (Msg, Buf.Chars'Last - Buf.Next + 1, Buf'Unchecked_Access);
649 Write_Buf (Buf'Unchecked_Access);
654 (Self_ID : ST.Task_ID;
659 Trace (Self_ID, Msg, null, Flag);
666 Self_ID : constant ST.Task_ID := STPO.Self;
669 Trace (Self_ID, Msg, null, Flag);
674 Other_ID : ST.Task_ID;
677 pragma Warnings (Off, Other_ID);
679 Self_ID : constant ST.Task_ID := STPO.Self;
682 Trace (Self_ID, Msg, null, Flag);
689 procedure Write_Buf (Buffer : Buffer_Ptr) is
690 Next : Buf_Range renames Buffer.Next;
691 Buf : Buf_Array renames Buffer.Chars;
693 procedure put_char (C : Integer);
694 pragma Import (C, put_char, "put_char");
697 for J in 1 .. Next - 1 loop
698 put_char (Character'Pos (Buf (J)));
701 put_char (Character'Pos (ASCII.LF));
704 end System.Tasking.Debug;