1------------------------------------------------------------------------------ 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-2013, 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 40with System.Address_Image; 41with System.CRTL; 42with System.Task_Primitives; 43with System.Task_Primitives.Operations; 44 45package body System.Tasking.Debug is 46 47 package STPO renames System.Task_Primitives.Operations; 48 49 type Trace_Flag_Set is array (Character) of Boolean; 50 51 Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); 52 53 Stderr_Fd : constant := 2; 54 -- File descriptor for standard error 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 procedure Write (Fd : Integer; S : String; Count : Integer); 61 -- Write Count characters of S to the file descriptor Fd 62 63 procedure Put (S : String); 64 -- Display S on standard error 65 66 procedure Put_Line (S : String := ""); 67 -- Display S on standard error with an additional line terminator 68 69 function Task_Image (T : Task_Id) return String; 70 -- Return the relevant characters from T.Common.Task_Image 71 72 function Task_Id_Image (T : Task_Id) return String; 73 -- Return the address in hexadecimal form 74 75 ------------------------ 76 -- Continue_All_Tasks -- 77 ------------------------ 78 79 procedure Continue_All_Tasks is 80 C : Task_Id; 81 82 Dummy : Boolean; 83 pragma Unreferenced (Dummy); 84 85 begin 86 STPO.Lock_RTS; 87 88 C := All_Tasks_List; 89 while C /= null loop 90 Dummy := STPO.Continue_Task (C); 91 C := C.Common.All_Tasks_Link; 92 end loop; 93 94 STPO.Unlock_RTS; 95 end Continue_All_Tasks; 96 97 -------------------- 98 -- Get_User_State -- 99 -------------------- 100 101 function Get_User_State return Long_Integer is 102 begin 103 return STPO.Self.User_State; 104 end Get_User_State; 105 106 ---------------- 107 -- List_Tasks -- 108 ---------------- 109 110 procedure List_Tasks is 111 C : Task_Id; 112 begin 113 C := All_Tasks_List; 114 115 while C /= null loop 116 Print_Task_Info (C); 117 C := C.Common.All_Tasks_Link; 118 end loop; 119 end List_Tasks; 120 121 ------------------------ 122 -- Print_Current_Task -- 123 ------------------------ 124 125 procedure Print_Current_Task is 126 begin 127 Print_Task_Info (STPO.Self); 128 end Print_Current_Task; 129 130 --------------------- 131 -- Print_Task_Info -- 132 --------------------- 133 134 procedure Print_Task_Info (T : Task_Id) is 135 Entry_Call : Entry_Call_Link; 136 Parent : Task_Id; 137 138 begin 139 if T = null then 140 Put_Line ("null task"); 141 return; 142 end if; 143 144 Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State)); 145 Parent := T.Common.Parent; 146 147 if Parent = null then 148 Put (", parent: <none>"); 149 else 150 Put (", parent: " & Task_Image (Parent)); 151 end if; 152 153 Put (", prio:" & T.Common.Current_Priority'Img); 154 155 if not T.Callable then 156 Put (", not callable"); 157 end if; 158 159 if T.Aborting then 160 Put (", aborting"); 161 end if; 162 163 if T.Deferral_Level /= 0 then 164 Put (", abort deferred"); 165 end if; 166 167 if T.Common.Call /= null then 168 Entry_Call := T.Common.Call; 169 Put (", serving:"); 170 171 while Entry_Call /= null loop 172 Put (Task_Id_Image (Entry_Call.Self)); 173 Entry_Call := Entry_Call.Acceptor_Prev_Call; 174 end loop; 175 end if; 176 177 if T.Open_Accepts /= null then 178 Put (", accepting:"); 179 180 for J in T.Open_Accepts'Range loop 181 Put (T.Open_Accepts (J).S'Img); 182 end loop; 183 184 if T.Terminate_Alternative then 185 Put (" or terminate"); 186 end if; 187 end if; 188 189 if T.User_State /= 0 then 190 Put (", state:" & T.User_State'Img); 191 end if; 192 193 Put_Line; 194 end Print_Task_Info; 195 196 --------- 197 -- Put -- 198 --------- 199 200 procedure Put (S : String) is 201 begin 202 Write (Stderr_Fd, S, S'Length); 203 end Put; 204 205 -------------- 206 -- Put_Line -- 207 -------------- 208 209 procedure Put_Line (S : String := "") is 210 begin 211 Write (Stderr_Fd, S & ASCII.LF, S'Length + 1); 212 end Put_Line; 213 214 ---------------------- 215 -- Resume_All_Tasks -- 216 ---------------------- 217 218 procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is 219 C : Task_Id; 220 Dummy : Boolean; 221 pragma Unreferenced (Dummy); 222 223 begin 224 STPO.Lock_RTS; 225 C := All_Tasks_List; 226 227 while C /= null loop 228 Dummy := STPO.Resume_Task (C, Thread_Self); 229 C := C.Common.All_Tasks_Link; 230 end loop; 231 232 STPO.Unlock_RTS; 233 end Resume_All_Tasks; 234 235 --------------- 236 -- Set_Trace -- 237 --------------- 238 239 procedure Set_Trace (Flag : Character; Value : Boolean := True) is 240 begin 241 Trace_On (Flag) := Value; 242 end Set_Trace; 243 244 -------------------- 245 -- Set_User_State -- 246 -------------------- 247 248 procedure Set_User_State (Value : Long_Integer) is 249 begin 250 STPO.Self.User_State := Value; 251 end Set_User_State; 252 253 ------------------------ 254 -- Signal_Debug_Event -- 255 ------------------------ 256 257 procedure Signal_Debug_Event 258 (Event_Kind : Event_Kind_Type; 259 Task_Value : Task_Id) 260 is 261 begin 262 null; 263 end Signal_Debug_Event; 264 265 -------------------- 266 -- Stop_All_Tasks -- 267 -------------------- 268 269 procedure Stop_All_Tasks is 270 C : Task_Id; 271 272 Dummy : Boolean; 273 pragma Unreferenced (Dummy); 274 275 begin 276 STPO.Lock_RTS; 277 278 C := All_Tasks_List; 279 while C /= null loop 280 Dummy := STPO.Stop_Task (C); 281 C := C.Common.All_Tasks_Link; 282 end loop; 283 284 STPO.Unlock_RTS; 285 end Stop_All_Tasks; 286 287 ---------------------------- 288 -- Stop_All_Tasks_Handler -- 289 ---------------------------- 290 291 procedure Stop_All_Tasks_Handler is 292 begin 293 STPO.Stop_All_Tasks; 294 end Stop_All_Tasks_Handler; 295 296 ----------------------- 297 -- Suspend_All_Tasks -- 298 ----------------------- 299 300 procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is 301 C : Task_Id; 302 Dummy : Boolean; 303 pragma Unreferenced (Dummy); 304 305 begin 306 STPO.Lock_RTS; 307 C := All_Tasks_List; 308 309 while C /= null loop 310 Dummy := STPO.Suspend_Task (C, Thread_Self); 311 C := C.Common.All_Tasks_Link; 312 end loop; 313 314 STPO.Unlock_RTS; 315 end Suspend_All_Tasks; 316 317 ------------------------ 318 -- Task_Creation_Hook -- 319 ------------------------ 320 321 procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is 322 pragma Inspection_Point (Thread); 323 -- gdb needs to access the thread parameter in order to implement 324 -- the multitask mode under VxWorks. 325 326 begin 327 null; 328 end Task_Creation_Hook; 329 330 ---------------- 331 -- Task_Id_Image -- 332 ---------------- 333 334 function Task_Id_Image (T : Task_Id) return String is 335 begin 336 if T = null then 337 return "Null_Task_Id"; 338 else 339 return Address_Image (T.all'Address); 340 end if; 341 end Task_Id_Image; 342 343 ---------------- 344 -- Task_Image -- 345 ---------------- 346 347 function Task_Image (T : Task_Id) return String is 348 begin 349 -- In case T.Common.Task_Image_Len is uninitialized junk, we check that 350 -- it is in range, to make this more robust. 351 352 if T.Common.Task_Image_Len in T.Common.Task_Image'Range then 353 return T.Common.Task_Image (1 .. T.Common.Task_Image_Len); 354 else 355 return T.Common.Task_Image; 356 end if; 357 end Task_Image; 358 359 --------------------------- 360 -- Task_Termination_Hook -- 361 --------------------------- 362 363 procedure Task_Termination_Hook is 364 begin 365 null; 366 end Task_Termination_Hook; 367 368 ----------- 369 -- Trace -- 370 ----------- 371 372 procedure Trace 373 (Self_Id : Task_Id; 374 Msg : String; 375 Flag : Character; 376 Other_Id : Task_Id := null) 377 is 378 begin 379 if Trace_On (Flag) then 380 Put (Task_Id_Image (Self_Id) & 381 ':' & Flag & ':' & 382 Task_Image (Self_Id) & 383 ':'); 384 385 if Other_Id /= null then 386 Put (Task_Id_Image (Other_Id) & ':'); 387 end if; 388 389 Put_Line (Msg); 390 end if; 391 end Trace; 392 393 ----------- 394 -- Write -- 395 ----------- 396 397 procedure Write (Fd : Integer; S : String; Count : Integer) is 398 Discard : System.CRTL.ssize_t; 399 pragma Unreferenced (Discard); 400 begin 401 Discard := System.CRTL.write (Fd, S'Address, 402 System.CRTL.size_t (Count)); 403 -- Ignore write errors here; this is just debugging output, and there's 404 -- nothing to be done about errors anyway. 405 end Write; 406 407end System.Tasking.Debug; 408