?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR sanitizer/80403
[official-gcc.git] / gcc / ada / s-tratas-default.adb
blob9e45771bd0924a0c30dddf2de9609959b291b542
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-2016, 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 -- 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
66 | PO_Done
67 =>
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);
73
74 when E_Missed =>
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);
80
81 when E_Kill =>
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);
86
87 when T_Create =>
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);
92
93 when others =>
94 null;
95 -- should raise an exception ???
96 end case;
97 end if;
98 end Send_Trace_Info;
99
100 procedure Send_Trace_Info
101 (Id : Trace_T;
102 Task_Name2 : Task_Id;
103 Entry_Number : Entry_Index)
104 is
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);
112
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;
116
117 begin
118 if Parameters.Runtime_Traces then
119 case Id is
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);
128
129 when W_Call =>
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);
137
138 when others =>
139 null;
140 -- should raise an exception ???
141 end case;
142 end if;
143 end Send_Trace_Info;
144
145 procedure Send_Trace_Info
146 (Id : Trace_T;
147 Task_Name : Task_Id;
148 Task_Name2 : Task_Id;
149 Entry_Number : Entry_Index)
150 is
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);
160
161 L0 : constant Integer := Task_S'Length;
162 L1 : constant Integer := Task_S'Length + Entry_S'Length;
163
164 begin
165 if Parameters.Runtime_Traces then
166 case Id is
167 when PO_Run =>
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);
175
176 when others =>
177 null;
178 -- should raise an exception ???
179 end case;
180 end if;
181 end Send_Trace_Info;
182
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);
187
188 L0 : constant Integer := Task_S'Length;
189
190 begin
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);
197 end if;
198 end Send_Trace_Info;
199
200 procedure Send_Trace_Info
201 (Id : Trace_T;
202 Task_Name : Task_Id;
203 Task_Name2 : Task_Id)
204 is
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);
212
213 L0 : constant Integer := Task2_S'Length;
214
215 begin
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);
222 end if;
223 end Send_Trace_Info;
224
225 procedure Send_Trace_Info
226 (Id : Trace_T;
227 Acceptor : Task_Id;
228 Entry_Number : Entry_Index;
229 Timeout : Duration)
230 is
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);
239
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;
244
245 begin
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);
256 end if;
257 end Send_Trace_Info;
258
259 procedure Send_Trace_Info
260 (Id : Trace_T;
261 Entry_Number : Entry_Index;
262 Timeout : Duration)
263 is
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);
269
270 L0 : constant Integer := Task_S'Length;
271 L1 : constant Integer := Task_S'Length + Entry_S'Length;
272
273 begin
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);
282 end if;
283 end Send_Trace_Info;
284
285 procedure Send_Trace_Info
286 (Id : Trace_T;
287 Task_Name : Task_Id;
288 Number : Integer)
289 is
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);
295
296 L0 : constant Integer := Task_S'Length;
297 L1 : constant Integer := Task_S'Length + Number_S'Length;
298
299 begin
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);
308 end if;
309 end Send_Trace_Info;
310
311 procedure Send_Trace_Info
312 (Id : Trace_T;
313 Task_Name : Task_Id;
314 Number : Integer;
315 Timeout : Duration)
316 is
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);
323
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;
328
329 begin
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);
340 end if;
341 end Send_Trace_Info;
342
343 ---------------------
344 -- Extract_Accepts --
345 ---------------------
346
347 -- This function returns a string in which all opened
348 -- Accepts or Selects are given, separated by semi-colons.
349
350 function Extract_Accepts (Task_Name : Task_Id) return String_Trace is
351 Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
352
353 begin
354 for J in Task_Name.Open_Accepts'First ..
355 Task_Name.Open_Accepts'Last - 1
356 loop
357 Info_Annex := Append (Info_Annex, Integer'Image
358 (Integer (Task_Name.Open_Accepts (J).S)) & ",");
359 end loop;
360
361 Info_Annex := Append (Info_Annex,
362 Integer'Image (Integer
363 (Task_Name.Open_Accepts
364 (Task_Name.Open_Accepts'Last).S)));
365 return Info_Annex;
366 end Extract_Accepts;
367 end System.Traces.Tasking;
Mirror of the offical gcc git repository hosted at gcc.gnu.org