1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T R A C E S . T A S K I N G --
9 -- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System.Tasking; use System.Tasking;
35 with System.Soft_Links;
36 with System.Parameters;
37 with System.Traces.Format; use System.Traces.Format;
38 with System.Traces; use System.Traces;
40 package body System.Traces.Tasking is
44 package SSL renames System.Soft_Links;
46 function Extract_Accepts (Task_Name : Task_Id) return String_Trace;
47 -- This function is used to extract data joined with
48 -- W_Select, WT_Select, W_Accept events
54 procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is
55 Task_S : constant String := SSL.Task_Name.all;
56 Task2_S : constant String :=
57 Task_Name2.Common.Task_Image
58 (1 .. Task_Name2.Common.Task_Image_Len);
59 Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
61 L0 : constant Integer := Task_S'Length;
62 L1 : constant Integer := Task2_S'Length;
65 if Parameters.Runtime_Traces then
67 when M_RDV_Complete | PO_Done =>
68 Trace_S (1 .. 3) := "/N:";
69 Trace_S (4 .. 3 + L0) := Task_S;
70 Trace_S (4 + L0 .. 6 + L0) := "/C:";
71 Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
72 Send_Trace (Id, Trace_S);
75 Trace_S (1 .. 3) := "/N:";
76 Trace_S (4 .. 3 + L0) := Task_S;
77 Trace_S (4 + L0 .. 6 + L0) := "/A:";
78 Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
79 Send_Trace (Id, Trace_S);
82 Trace_S (1 .. 3) := "/N:";
83 Trace_S (4 .. 3 + L1) := Task2_S;
84 Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
85 Send_Trace (Id, Trace_S);
88 Trace_S (1 .. 3) := "/N:";
89 Trace_S (4 .. 3 + L1) := Task2_S;
90 Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
91 Send_Trace (Id, Trace_S);
95 -- should raise an exception ???
100 procedure Send_Trace_Info
102 Task_Name2 : Task_Id;
103 Entry_Number : Entry_Index)
105 Task_S : constant String := SSL.Task_Name.all;
106 Task2_S : constant String :=
107 Task_Name2.Common.Task_Image
108 (1 .. Task_Name2.Common.Task_Image_Len);
109 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
110 Trace_S : String (1 .. 9 + Task_S'Length
111 + Task2_S'Length + Entry_S'Length);
113 L0 : constant Integer := Task_S'Length;
114 L1 : constant Integer := Task_S'Length + Entry_S'Length;
115 L2 : constant Integer := Task_S'Length + Task2_S'Length;
118 if Parameters.Runtime_Traces then
120 when M_Accept_Complete =>
121 Trace_S (1 .. 3) := "/N:";
122 Trace_S (4 .. 3 + L0) := Task_S;
123 Trace_S (4 + L0 .. 6 + L0) := "/E:";
124 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
125 Trace_S (7 + L1 .. 9 + L1) := "/C:";
126 Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
127 Send_Trace (Id, Trace_S);
130 Trace_S (1 .. 3) := "/N:";
131 Trace_S (4 .. 3 + L0) := Task_S;
132 Trace_S (4 + L0 .. 6 + L0) := "/A:";
133 Trace_S (7 + L0 .. 6 + L2) := Task2_S;
134 Trace_S (7 + L2 .. 9 + L2) := "/C:";
135 Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
136 Send_Trace (Id, Trace_S);
140 -- should raise an exception ???
145 procedure Send_Trace_Info
148 Task_Name2 : Task_Id;
149 Entry_Number : Entry_Index)
151 Task_S : constant String :=
152 Task_Name.Common.Task_Image
153 (1 .. Task_Name.Common.Task_Image_Len);
154 Task2_S : constant String :=
155 Task_Name2.Common.Task_Image
156 (1 .. Task_Name2.Common.Task_Image_Len);
157 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
158 Trace_S : String (1 .. 9 + Task_S'Length
159 + Task2_S'Length + Entry_S'Length);
161 L0 : constant Integer := Task_S'Length;
162 L1 : constant Integer := Task_S'Length + Entry_S'Length;
165 if Parameters.Runtime_Traces then
168 Trace_S (1 .. 3) := "/N:";
169 Trace_S (4 .. 3 + L0) := Task_S;
170 Trace_S (4 + L0 .. 6 + L0) := "/E:";
171 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
172 Trace_S (7 + L1 .. 9 + L1) := "/C:";
173 Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
174 Send_Trace (Id, Trace_S);
178 -- should raise an exception ???
183 procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
184 Task_S : constant String := SSL.Task_Name.all;
185 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
186 Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
188 L0 : constant Integer := Task_S'Length;
191 if Parameters.Runtime_Traces then
192 Trace_S (1 .. 3) := "/N:";
193 Trace_S (4 .. 3 + L0) := Task_S;
194 Trace_S (4 + L0 .. 6 + L0) := "/E:";
195 Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
196 Send_Trace (Id, Trace_S);
200 procedure Send_Trace_Info
203 Task_Name2 : Task_Id)
205 Task_S : constant String :=
206 Task_Name.Common.Task_Image
207 (1 .. Task_Name.Common.Task_Image_Len);
208 Task2_S : constant String :=
209 Task_Name2.Common.Task_Image
210 (1 .. Task_Name2.Common.Task_Image_Len);
211 Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
213 L0 : constant Integer := Task2_S'Length;
216 if Parameters.Runtime_Traces then
217 Trace_S (1 .. 3) := "/N:";
218 Trace_S (4 .. 3 + L0) := Task2_S;
219 Trace_S (4 + L0 .. 6 + L0) := "/P:";
220 Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
221 Send_Trace (Id, Trace_S);
225 procedure Send_Trace_Info
228 Entry_Number : Entry_Index;
231 Task_S : constant String := SSL.Task_Name.all;
232 Acceptor_S : constant String :=
233 Acceptor.Common.Task_Image
234 (1 .. Acceptor.Common.Task_Image_Len);
235 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
236 Timeout_S : constant String := Duration'Image (Timeout);
237 Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
238 + Entry_S'Length + Timeout_S'Length);
240 L0 : constant Integer := Task_S'Length;
241 L1 : constant Integer := Task_S'Length + Acceptor_S'Length;
242 L2 : constant Integer :=
243 Task_S'Length + Acceptor_S'Length + Entry_S'Length;
246 if Parameters.Runtime_Traces then
247 Trace_S (1 .. 3) := "/N:";
248 Trace_S (4 .. 3 + L0) := Task_S;
249 Trace_S (4 + L0 .. 6 + L0) := "/A:";
250 Trace_S (7 + L0 .. 6 + L1) := Acceptor_S;
251 Trace_S (7 + L1 .. 9 + L1) := "/E:";
252 Trace_S (10 + L1 .. 9 + L2) := Entry_S;
253 Trace_S (10 + L2 .. 12 + L2) := "/T:";
254 Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
255 Send_Trace (Id, Trace_S);
259 procedure Send_Trace_Info
261 Entry_Number : Entry_Index;
264 Task_S : constant String := SSL.Task_Name.all;
265 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
266 Timeout_S : constant String := Duration'Image (Timeout);
267 Trace_S : String (1 .. 9 + Task_S'Length
268 + Entry_S'Length + Timeout_S'Length);
270 L0 : constant Integer := Task_S'Length;
271 L1 : constant Integer := Task_S'Length + Entry_S'Length;
274 if Parameters.Runtime_Traces then
275 Trace_S (1 .. 3) := "/N:";
276 Trace_S (4 .. 3 + L0) := Task_S;
277 Trace_S (4 + L0 .. 6 + L0) := "/E:";
278 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
279 Trace_S (7 + L1 .. 9 + L1) := "/T:";
280 Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
281 Send_Trace (Id, Trace_S);
285 procedure Send_Trace_Info
290 Task_S : constant String := SSL.Task_Name.all;
291 Number_S : constant String := Integer'Image (Number);
292 Accepts_S : constant String := Extract_Accepts (Task_Name);
293 Trace_S : String (1 .. 9 + Task_S'Length
294 + Number_S'Length + Accepts_S'Length);
296 L0 : constant Integer := Task_S'Length;
297 L1 : constant Integer := Task_S'Length + Number_S'Length;
300 if Parameters.Runtime_Traces then
301 Trace_S (1 .. 3) := "/N:";
302 Trace_S (4 .. 3 + L0) := Task_S;
303 Trace_S (4 + L0 .. 6 + L0) := "/#:";
304 Trace_S (7 + L0 .. 6 + L1) := Number_S;
305 Trace_S (7 + L1 .. 9 + L1) := "/E:";
306 Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
307 Send_Trace (Id, Trace_S);
311 procedure Send_Trace_Info
317 Task_S : constant String := SSL.Task_Name.all;
318 Timeout_S : constant String := Duration'Image (Timeout);
319 Number_S : constant String := Integer'Image (Number);
320 Accepts_S : constant String := Extract_Accepts (Task_Name);
321 Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length
322 + Number_S'Length + Accepts_S'Length);
324 L0 : constant Integer := Task_S'Length;
325 L1 : constant Integer := Task_S'Length + Timeout_S'Length;
326 L2 : constant Integer :=
327 Task_S'Length + Timeout_S'Length + Number_S'Length;
330 if Parameters.Runtime_Traces then
331 Trace_S (1 .. 3) := "/N:";
332 Trace_S (4 .. 3 + L0) := Task_S;
333 Trace_S (4 + L0 .. 6 + L0) := "/T:";
334 Trace_S (7 + L0 .. 6 + L1) := Timeout_S;
335 Trace_S (7 + L1 .. 9 + L1) := "/#:";
336 Trace_S (10 + L1 .. 9 + L2) := Number_S;
337 Trace_S (10 + L2 .. 12 + L2) := "/E:";
338 Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
339 Send_Trace (Id, Trace_S);
343 ---------------------
344 -- Extract_Accepts --
345 ---------------------
347 -- This function returns a string in which all opened
348 -- Accepts or Selects are given, separated by semi-colons.
350 function Extract_Accepts (Task_Name : Task_Id) return String_Trace is
351 Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
354 for J in Task_Name.Open_Accepts'First ..
355 Task_Name.Open_Accepts'Last - 1
357 Info_Annex := Append (Info_Annex, Integer'Image
358 (Integer (Task_Name.Open_Accepts (J).S)) & ",");
361 Info_Annex := Append (Info_Annex,
362 Integer'Image (Integer
363 (Task_Name.Open_Accepts
364 (Task_Name.Open_Accepts'Last).S)));
367 end System.Traces.Tasking;