URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasdeb.adb] - Blame information for rev 801

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
--                                                                          --
--                  S Y S T E M . T A S K I N G . D E B U G                 --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--          Copyright (C) 1997-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------
 
--  This package encapsulates all direct interfaces to task debugging services
--  that are needed by gdb with gnat mode.
 
--  Note : This file *must* be compiled with debugging information
 
--  Do not add any dependency to GNARL packages since this package is used
--  in both normal and restricted (ravenscar) environments.
 
with System.CRTL;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with Ada.Unchecked_Conversion;
 
package body System.Tasking.Debug is
 
   package STPO renames System.Task_Primitives.Operations;
 
   function To_Integer is new
     Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address);
 
   type Trace_Flag_Set is array (Character) of Boolean;
 
   Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   procedure Write (Fd : Integer; S : String; Count : Integer);
 
   procedure Put (S : String);
   --  Display S on standard output
 
   procedure Put_Line (S : String := "");
   --  Display S on standard output with an additional line terminator
 
   ------------------------
   -- Continue_All_Tasks --
   ------------------------
 
   procedure Continue_All_Tasks is
      C : Task_Id;
 
      Dummy : Boolean;
      pragma Unreferenced (Dummy);
 
   begin
      STPO.Lock_RTS;
 
      C := All_Tasks_List;
      while C /= null loop
         Dummy := STPO.Continue_Task (C);
         C := C.Common.All_Tasks_Link;
      end loop;
 
      STPO.Unlock_RTS;
   end Continue_All_Tasks;
 
   --------------------
   -- Get_User_State --
   --------------------
 
   function Get_User_State return Long_Integer is
   begin
      return STPO.Self.User_State;
   end Get_User_State;
 
   ----------------
   -- List_Tasks --
   ----------------
 
   procedure List_Tasks is
      C : Task_Id;
   begin
      C := All_Tasks_List;
 
      while C /= null loop
         Print_Task_Info (C);
         C := C.Common.All_Tasks_Link;
      end loop;
   end List_Tasks;
 
   ------------------------
   -- Print_Current_Task --
   ------------------------
 
   procedure Print_Current_Task is
   begin
      Print_Task_Info (STPO.Self);
   end Print_Current_Task;
 
   ---------------------
   -- Print_Task_Info --
   ---------------------
 
   procedure Print_Task_Info (T : Task_Id) is
      Entry_Call : Entry_Call_Link;
      Parent     : Task_Id;
 
   begin
      if T = null then
         Put_Line ("null task");
         return;
      end if;
 
      Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
           Task_States'Image (T.Common.State));
 
      Parent := T.Common.Parent;
 
      if Parent = null then
         Put (", parent: <none>");
      else
         Put (", parent: " &
              Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
      end if;
 
      Put (", prio:" & T.Common.Current_Priority'Img);
 
      if not T.Callable then
         Put (", not callable");
      end if;
 
      if T.Aborting then
         Put (", aborting");
      end if;
 
      if T.Deferral_Level /= 0 then
         Put (", abort deferred");
      end if;
 
      if T.Common.Call /= null then
         Entry_Call := T.Common.Call;
         Put (", serving:");
 
         while Entry_Call /= null loop
            Put (To_Integer (Entry_Call.Self)'Img);
            Entry_Call := Entry_Call.Acceptor_Prev_Call;
         end loop;
      end if;
 
      if T.Open_Accepts /= null then
         Put (", accepting:");
 
         for J in T.Open_Accepts'Range loop
            Put (T.Open_Accepts (J).S'Img);
         end loop;
 
         if T.Terminate_Alternative then
            Put (" or terminate");
         end if;
      end if;
 
      if T.User_State /= 0 then
         Put (", state:" & T.User_State'Img);
      end if;
 
      Put_Line;
   end Print_Task_Info;
 
   ---------
   -- Put --
   ---------
 
   procedure Put (S : String) is
   begin
      Write (2, S, S'Length);
   end Put;
 
   --------------
   -- Put_Line --
   --------------
 
   procedure Put_Line (S : String := "") is
   begin
      Write (2, S & ASCII.LF, S'Length + 1);
   end Put_Line;
 
   ----------------------
   -- Resume_All_Tasks --
   ----------------------
 
   procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
      C     : Task_Id;
      Dummy : Boolean;
      pragma Unreferenced (Dummy);
 
   begin
      STPO.Lock_RTS;
      C := All_Tasks_List;
 
      while C /= null loop
         Dummy := STPO.Resume_Task (C, Thread_Self);
         C := C.Common.All_Tasks_Link;
      end loop;
 
      STPO.Unlock_RTS;
   end Resume_All_Tasks;
 
   ---------------
   -- Set_Trace --
   ---------------
 
   procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
   begin
      Trace_On (Flag) := Value;
   end Set_Trace;
 
   --------------------
   -- Set_User_State --
   --------------------
 
   procedure Set_User_State (Value : Long_Integer) is
   begin
      STPO.Self.User_State := Value;
   end Set_User_State;
 
   ------------------------
   -- Signal_Debug_Event --
   ------------------------
 
   procedure Signal_Debug_Event
     (Event_Kind : Event_Kind_Type;
      Task_Value : Task_Id)
   is
   begin
      null;
   end Signal_Debug_Event;
 
   --------------------
   -- Stop_All_Tasks --
   --------------------
 
   procedure Stop_All_Tasks is
      C : Task_Id;
 
      Dummy : Boolean;
      pragma Unreferenced (Dummy);
 
   begin
      STPO.Lock_RTS;
 
      C := All_Tasks_List;
      while C /= null loop
         Dummy := STPO.Stop_Task (C);
         C := C.Common.All_Tasks_Link;
      end loop;
 
      STPO.Unlock_RTS;
   end Stop_All_Tasks;
 
   ----------------------------
   -- Stop_All_Tasks_Handler --
   ----------------------------
 
   procedure Stop_All_Tasks_Handler is
   begin
      STPO.Stop_All_Tasks;
   end Stop_All_Tasks_Handler;
 
   -----------------------
   -- Suspend_All_Tasks --
   -----------------------
 
   procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
      C     : Task_Id;
      Dummy : Boolean;
      pragma Unreferenced (Dummy);
 
   begin
      STPO.Lock_RTS;
      C := All_Tasks_List;
 
      while C /= null loop
         Dummy := STPO.Suspend_Task (C, Thread_Self);
         C := C.Common.All_Tasks_Link;
      end loop;
 
      STPO.Unlock_RTS;
   end Suspend_All_Tasks;
 
   ------------------------
   -- Task_Creation_Hook --
   ------------------------
 
   procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
      pragma Inspection_Point (Thread);
      --  gdb needs to access the thread parameter in order to implement
      --  the multitask mode under VxWorks.
 
   begin
      null;
   end Task_Creation_Hook;
 
   ---------------------------
   -- Task_Termination_Hook --
   ---------------------------
 
   procedure Task_Termination_Hook is
   begin
      null;
   end Task_Termination_Hook;
 
   -----------
   -- Trace --
   -----------
 
   procedure Trace
     (Self_Id  : Task_Id;
      Msg      : String;
      Flag     : Character;
      Other_Id : Task_Id := null)
   is
   begin
      if Trace_On (Flag) then
         Put (To_Integer (Self_Id)'Img &
              ':' & Flag & ':' &
              Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
              ':');
 
         if Other_Id /= null then
            Put (To_Integer (Other_Id)'Img & ':');
         end if;
 
         Put_Line (Msg);
      end if;
   end Trace;
 
   -----------
   -- Write --
   -----------
 
   procedure Write (Fd : Integer; S : String; Count : Integer) is
      Discard : System.CRTL.ssize_t;
      pragma Unreferenced (Discard);
   begin
      Discard := System.CRTL.write (Fd, S (S'First)'Address,
                                    System.CRTL.size_t (Count));
      --  Is it really right to ignore write errors here ???
   end Write;
 
end System.Tasking.Debug;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasdeb.adb] - Blame information for rev 801

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
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
40			`with System.CRTL;`
41			`with System.Task_Primitives;`
42			`with System.Task_Primitives.Operations;`
43			`with Ada.Unchecked_Conversion;`
44
45			`package 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
373			`end System.Tasking.Debug;`