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