File : s-tratas-default.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T R A C E S . T A S K I N G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2014, 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 -- --
19 -- --
20 -- --
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 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Tasking; use System.Tasking;
33 with System.Soft_Links;
34 with System.Parameters;
35 with System.Traces.Format; use System.Traces.Format;
36 with System.Traces; use System.Traces;
37
38 package body System.Traces.Tasking is
39
40 use System.Traces;
41
42 package SSL renames System.Soft_Links;
43
44 function Extract_Accepts (Task_Name : Task_Id) return String_Trace;
45 -- This function is used to extract data joined with
46 -- W_Select, WT_Select, W_Accept events
47
48 ---------------------
49 -- Send_Trace_Info --
50 ---------------------
51
52 procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is
53 Task_S : constant String := SSL.Task_Name.all;
54 Task2_S : constant String :=
55 Task_Name2.Common.Task_Image
56 (1 .. Task_Name2.Common.Task_Image_Len);
57 Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
58
59 L0 : constant Integer := Task_S'Length;
60 L1 : constant Integer := Task2_S'Length;
61
62 begin
63 if Parameters.Runtime_Traces then
64 case Id is
65 when M_RDV_Complete | PO_Done =>
66 Trace_S (1 .. 3) := "/N:";
67 Trace_S (4 .. 3 + L0) := Task_S;
68 Trace_S (4 + L0 .. 6 + L0) := "/C:";
69 Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
70 Send_Trace (Id, Trace_S);
71
72 when E_Missed =>
73 Trace_S (1 .. 3) := "/N:";
74 Trace_S (4 .. 3 + L0) := Task_S;
75 Trace_S (4 + L0 .. 6 + L0) := "/A:";
76 Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
77 Send_Trace (Id, Trace_S);
78
79 when E_Kill =>
80 Trace_S (1 .. 3) := "/N:";
81 Trace_S (4 .. 3 + L1) := Task2_S;
82 Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
83 Send_Trace (Id, Trace_S);
84
85 when T_Create =>
86 Trace_S (1 .. 3) := "/N:";
87 Trace_S (4 .. 3 + L1) := Task2_S;
88 Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
89 Send_Trace (Id, Trace_S);
90
91 when others =>
92 null;
93 -- should raise an exception ???
94 end case;
95 end if;
96 end Send_Trace_Info;
97
98 procedure Send_Trace_Info
99 (Id : Trace_T;
100 Task_Name2 : Task_Id;
101 Entry_Number : Entry_Index)
102 is
103 Task_S : constant String := SSL.Task_Name.all;
104 Task2_S : constant String :=
105 Task_Name2.Common.Task_Image
106 (1 .. Task_Name2.Common.Task_Image_Len);
107 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
108 Trace_S : String (1 .. 9 + Task_S'Length
109 + Task2_S'Length + Entry_S'Length);
110
111 L0 : constant Integer := Task_S'Length;
112 L1 : constant Integer := Task_S'Length + Entry_S'Length;
113 L2 : constant Integer := Task_S'Length + Task2_S'Length;
114
115 begin
116 if Parameters.Runtime_Traces then
117 case Id is
118 when M_Accept_Complete =>
119 Trace_S (1 .. 3) := "/N:";
120 Trace_S (4 .. 3 + L0) := Task_S;
121 Trace_S (4 + L0 .. 6 + L0) := "/E:";
122 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
123 Trace_S (7 + L1 .. 9 + L1) := "/C:";
124 Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
125 Send_Trace (Id, Trace_S);
126
127 when W_Call =>
128 Trace_S (1 .. 3) := "/N:";
129 Trace_S (4 .. 3 + L0) := Task_S;
130 Trace_S (4 + L0 .. 6 + L0) := "/A:";
131 Trace_S (7 + L0 .. 6 + L2) := Task2_S;
132 Trace_S (7 + L2 .. 9 + L2) := "/C:";
133 Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
134 Send_Trace (Id, Trace_S);
135
136 when others =>
137 null;
138 -- should raise an exception ???
139 end case;
140 end if;
141 end Send_Trace_Info;
142
143 procedure Send_Trace_Info
144 (Id : Trace_T;
145 Task_Name : Task_Id;
146 Task_Name2 : Task_Id;
147 Entry_Number : Entry_Index)
148 is
149 Task_S : constant String :=
150 Task_Name.Common.Task_Image
151 (1 .. Task_Name.Common.Task_Image_Len);
152 Task2_S : constant String :=
153 Task_Name2.Common.Task_Image
154 (1 .. Task_Name2.Common.Task_Image_Len);
155 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
156 Trace_S : String (1 .. 9 + Task_S'Length
157 + Task2_S'Length + Entry_S'Length);
158
159 L0 : constant Integer := Task_S'Length;
160 L1 : constant Integer := Task_S'Length + Entry_S'Length;
161
162 begin
163 if Parameters.Runtime_Traces then
164 case Id is
165 when PO_Run =>
166 Trace_S (1 .. 3) := "/N:";
167 Trace_S (4 .. 3 + L0) := Task_S;
168 Trace_S (4 + L0 .. 6 + L0) := "/E:";
169 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
170 Trace_S (7 + L1 .. 9 + L1) := "/C:";
171 Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
172 Send_Trace (Id, Trace_S);
173
174 when others =>
175 null;
176 -- should raise an exception ???
177 end case;
178 end if;
179 end Send_Trace_Info;
180
181 procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
182 Task_S : constant String := SSL.Task_Name.all;
183 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
184 Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
185
186 L0 : constant Integer := Task_S'Length;
187
188 begin
189 if Parameters.Runtime_Traces then
190 Trace_S (1 .. 3) := "/N:";
191 Trace_S (4 .. 3 + L0) := Task_S;
192 Trace_S (4 + L0 .. 6 + L0) := "/E:";
193 Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
194 Send_Trace (Id, Trace_S);
195 end if;
196 end Send_Trace_Info;
197
198 procedure Send_Trace_Info
199 (Id : Trace_T;
200 Task_Name : Task_Id;
201 Task_Name2 : Task_Id)
202 is
203 Task_S : constant String :=
204 Task_Name.Common.Task_Image
205 (1 .. Task_Name.Common.Task_Image_Len);
206 Task2_S : constant String :=
207 Task_Name2.Common.Task_Image
208 (1 .. Task_Name2.Common.Task_Image_Len);
209 Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
210
211 L0 : constant Integer := Task2_S'Length;
212
213 begin
214 if Parameters.Runtime_Traces then
215 Trace_S (1 .. 3) := "/N:";
216 Trace_S (4 .. 3 + L0) := Task2_S;
217 Trace_S (4 + L0 .. 6 + L0) := "/P:";
218 Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
219 Send_Trace (Id, Trace_S);
220 end if;
221 end Send_Trace_Info;
222
223 procedure Send_Trace_Info
224 (Id : Trace_T;
225 Acceptor : Task_Id;
226 Entry_Number : Entry_Index;
227 Timeout : Duration)
228 is
229 Task_S : constant String := SSL.Task_Name.all;
230 Acceptor_S : constant String :=
231 Acceptor.Common.Task_Image
232 (1 .. Acceptor.Common.Task_Image_Len);
233 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
234 Timeout_S : constant String := Duration'Image (Timeout);
235 Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
236 + Entry_S'Length + Timeout_S'Length);
237
238 L0 : constant Integer := Task_S'Length;
239 L1 : constant Integer := Task_S'Length + Acceptor_S'Length;
240 L2 : constant Integer :=
241 Task_S'Length + Acceptor_S'Length + Entry_S'Length;
242
243 begin
244 if Parameters.Runtime_Traces then
245 Trace_S (1 .. 3) := "/N:";
246 Trace_S (4 .. 3 + L0) := Task_S;
247 Trace_S (4 + L0 .. 6 + L0) := "/A:";
248 Trace_S (7 + L0 .. 6 + L1) := Acceptor_S;
249 Trace_S (7 + L1 .. 9 + L1) := "/E:";
250 Trace_S (10 + L1 .. 9 + L2) := Entry_S;
251 Trace_S (10 + L2 .. 12 + L2) := "/T:";
252 Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
253 Send_Trace (Id, Trace_S);
254 end if;
255 end Send_Trace_Info;
256
257 procedure Send_Trace_Info
258 (Id : Trace_T;
259 Entry_Number : Entry_Index;
260 Timeout : Duration)
261 is
262 Task_S : constant String := SSL.Task_Name.all;
263 Entry_S : constant String := Integer'Image (Integer (Entry_Number));
264 Timeout_S : constant String := Duration'Image (Timeout);
265 Trace_S : String (1 .. 9 + Task_S'Length
266 + Entry_S'Length + Timeout_S'Length);
267
268 L0 : constant Integer := Task_S'Length;
269 L1 : constant Integer := Task_S'Length + Entry_S'Length;
270
271 begin
272 if Parameters.Runtime_Traces then
273 Trace_S (1 .. 3) := "/N:";
274 Trace_S (4 .. 3 + L0) := Task_S;
275 Trace_S (4 + L0 .. 6 + L0) := "/E:";
276 Trace_S (7 + L0 .. 6 + L1) := Entry_S;
277 Trace_S (7 + L1 .. 9 + L1) := "/T:";
278 Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
279 Send_Trace (Id, Trace_S);
280 end if;
281 end Send_Trace_Info;
282
283 procedure Send_Trace_Info
284 (Id : Trace_T;
285 Task_Name : Task_Id;
286 Number : Integer)
287 is
288 Task_S : constant String := SSL.Task_Name.all;
289 Number_S : constant String := Integer'Image (Number);
290 Accepts_S : constant String := Extract_Accepts (Task_Name);
291 Trace_S : String (1 .. 9 + Task_S'Length
292 + Number_S'Length + Accepts_S'Length);
293
294 L0 : constant Integer := Task_S'Length;
295 L1 : constant Integer := Task_S'Length + Number_S'Length;
296
297 begin
298 if Parameters.Runtime_Traces then
299 Trace_S (1 .. 3) := "/N:";
300 Trace_S (4 .. 3 + L0) := Task_S;
301 Trace_S (4 + L0 .. 6 + L0) := "/#:";
302 Trace_S (7 + L0 .. 6 + L1) := Number_S;
303 Trace_S (7 + L1 .. 9 + L1) := "/E:";
304 Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
305 Send_Trace (Id, Trace_S);
306 end if;
307 end Send_Trace_Info;
308
309 procedure Send_Trace_Info
310 (Id : Trace_T;
311 Task_Name : Task_Id;
312 Number : Integer;
313 Timeout : Duration)
314 is
315 Task_S : constant String := SSL.Task_Name.all;
316 Timeout_S : constant String := Duration'Image (Timeout);
317 Number_S : constant String := Integer'Image (Number);
318 Accepts_S : constant String := Extract_Accepts (Task_Name);
319 Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length
320 + Number_S'Length + Accepts_S'Length);
321
322 L0 : constant Integer := Task_S'Length;
323 L1 : constant Integer := Task_S'Length + Timeout_S'Length;
324 L2 : constant Integer :=
325 Task_S'Length + Timeout_S'Length + Number_S'Length;
326
327 begin
328 if Parameters.Runtime_Traces then
329 Trace_S (1 .. 3) := "/N:";
330 Trace_S (4 .. 3 + L0) := Task_S;
331 Trace_S (4 + L0 .. 6 + L0) := "/T:";
332 Trace_S (7 + L0 .. 6 + L1) := Timeout_S;
333 Trace_S (7 + L1 .. 9 + L1) := "/#:";
334 Trace_S (10 + L1 .. 9 + L2) := Number_S;
335 Trace_S (10 + L2 .. 12 + L2) := "/E:";
336 Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
337 Send_Trace (Id, Trace_S);
338 end if;
339 end Send_Trace_Info;
340
341 ---------------------
342 -- Extract_Accepts --
343 ---------------------
344
345 -- This function returns a string in which all opened
346 -- Accepts or Selects are given, separated by semi-colons.
347
348 function Extract_Accepts (Task_Name : Task_Id) return String_Trace is
349 Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
350
351 begin
352 for J in Task_Name.Open_Accepts'First ..
353 Task_Name.Open_Accepts'Last - 1
354 loop
355 Info_Annex := Append (Info_Annex, Integer'Image
356 (Integer (Task_Name.Open_Accepts (J).S)) & ",");
357 end loop;
358
359 Info_Annex := Append (Info_Annex,
360 Integer'Image (Integer
361 (Task_Name.Open_Accepts
362 (Task_Name.Open_Accepts'Last).S)));
363 return Info_Annex;
364 end Extract_Accepts;
365 end System.Traces.Tasking;