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-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-- 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 32with System.Tasking; use System.Tasking; 33with System.Soft_Links; 34with System.Parameters; 35with System.Traces.Format; use System.Traces.Format; 36with System.Traces; use System.Traces; 37 38package 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; 365end System.Traces.Tasking; 366