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) 2008-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT 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-- OpenVMS Version 33 34with Ada.Unchecked_Conversion; 35with Ada.Unchecked_Deallocation; 36with System.Aux_DEC; 37with System.CRTL; 38with System.Task_Primitives.Operations; 39package body System.Tasking.Debug is 40 41 package OSI renames System.OS_Interface; 42 package STPO renames System.Task_Primitives.Operations; 43 44 use System.Aux_DEC; 45 46 -- Condition value type 47 48 subtype Cond_Value_Type is Unsigned_Longword; 49 50 type Trace_Flag_Set is array (Character) of Boolean; 51 52 Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); 53 54 -- Print_Routine fuction codes 55 56 type Print_Functions is 57 (No_Print, Print_Newline, Print_Control, 58 Print_String, Print_Symbol, Print_FAO); 59 for Print_Functions use 60 (No_Print => 0, Print_Newline => 1, Print_Control => 2, 61 Print_String => 3, Print_Symbol => 4, Print_FAO => 5); 62 63 -- Counted ascii type declarations 64 65 subtype Count_Type is Natural range 0 .. 255; 66 for Count_Type'Object_Size use 8; 67 68 type ASCIC (Count : Count_Type) is record 69 Text : String (1 .. Count); 70 end record; 71 72 for ASCIC use record 73 Count at 0 range 0 .. 7; 74 end record; 75 pragma Pack (ASCIC); 76 77 type AASCIC is access ASCIC; 78 for AASCIC'Size use 32; 79 80 type AASCIC_Array is array (Positive range <>) of AASCIC; 81 82 type ASCIC127 is record 83 Count : Count_Type; 84 Text : String (1 .. 127); 85 end record; 86 87 for ASCIC127 use record 88 Count at 0 range 0 .. 7; 89 Text at 1 range 0 .. 127 * 8 - 1; 90 end record; 91 92 -- DEBUG Event record types used to signal DEBUG about Ada events 93 94 type Debug_Event_Record is record 95 Code : Unsigned_Word; -- Event code that uniquely identifies event 96 Flags : Bit_Array_8; -- Flag bits 97 -- Bit 0: This event allows a parameter list 98 -- Bit 1: Parameters are address expressions 99 Sentinal : Unsigned_Byte; -- Sentinal valuye: Always K_EVENT_SENT 100 TS_Kind : Unsigned_Byte; -- DST type specification: Always K_TS_TASK 101 DType : Unsigned_Byte; -- DTYPE of parameter if of atomic data type 102 -- Always K_DTYPE_TASK 103 MBZ : Unsigned_Byte; -- Unused (must be zero) 104 Minchr : Count_Type; -- Minimum chars needed to identify event 105 Name : ASCIC (31); -- Event name uppercase only 106 Help : AASCIC; -- Event description 107 end record; 108 109 for Debug_Event_Record use record 110 Code at 0 range 0 .. 15; 111 Flags at 2 range 0 .. 7; 112 Sentinal at 3 range 0 .. 7; 113 TS_Kind at 4 range 0 .. 7; 114 Dtype at 5 range 0 .. 7; 115 MBZ at 6 range 0 .. 7; 116 Minchr at 7 range 0 .. 7; 117 Name at 8 range 0 .. 32 * 8 - 1; 118 Help at 40 range 0 .. 31; 119 end record; 120 121 type Ada_Event_Control_Block_Type is record 122 Code : Unsigned_Word; -- Reserved and defined by DEBUG 123 Unused1 : Unsigned_Byte; -- Reserved and defined by DEBUG 124 Sentinal : Unsigned_Byte; -- Reserved and defined by DEBUG 125 Facility : Unsigned_Word; -- Reserved and defined by DEBUG 126 Flags : Unsigned_Word; -- Reserved and defined by DEBUG 127 Value : Unsigned_Longword; -- Reserved and defined by DEBUG 128 Unused2 : Unsigned_Longword; -- Reserved and defined by DEBUG 129 Sigargs : Unsigned_Longword; 130 P1 : Unsigned_Longword; 131 Sub_Event : Unsigned_Longword; 132 end record; 133 134 for Ada_Event_Control_Block_Type use record 135 Code at 0 range 0 .. 15; 136 Unused1 at 2 range 0 .. 7; 137 Sentinal at 3 range 0 .. 7; 138 Facility at 4 range 0 .. 15; 139 Flags at 6 range 0 .. 15; 140 Value at 8 range 0 .. 31; 141 Unused2 at 12 range 0 .. 31; 142 Sigargs at 16 range 0 .. 31; 143 P1 at 20 range 0 .. 31; 144 Sub_Event at 24 range 0 .. 31; 145 end record; 146 147 type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type; 148 for Ada_Event_Control_Block_Access'Size use 32; 149 150 -- Print_Routine_Type with max optional parameters 151 152 type Print_Routine_Type is access procedure 153 (Print_Function : Print_Functions; 154 Print_Subfunction : Print_Functions; 155 P1 : Unsigned_Longword := 0; 156 P2 : Unsigned_Longword := 0; 157 P3 : Unsigned_Longword := 0; 158 P4 : Unsigned_Longword := 0; 159 P5 : Unsigned_Longword := 0; 160 P6 : Unsigned_Longword := 0); 161 for Print_Routine_Type'Size use 32; 162 163 --------------- 164 -- Constants -- 165 --------------- 166 167 -- These are used to obtain and convert task values 168 K_CVT_VALUE_NUM : constant := 1; 169 K_CVT_NUM_VALUE : constant := 2; 170 K_NEXT_TASK : constant := 3; 171 172 -- These are used to ask ADA to display task information 173 K_SHOW_TASK : constant := 4; 174 K_SHOW_STAT : constant := 5; 175 K_SHOW_DEADLOCK : constant := 6; 176 177 -- These are used to get and set various attributes of one or more tasks 178 -- Task state 179 -- K_GET_STATE : constant := 7; 180 -- K_GET_ACTIVE : constant := 8; 181 -- K_SET_ACTIVE : constant := 9; 182 K_SET_ABORT : constant := 10; 183 -- K_SET_HOLD : constant := 11; 184 185 -- Task priority 186 K_GET_PRIORITY : constant := 12; 187 K_SET_PRIORITY : constant := 13; 188 K_RESTORE_PRIORITY : constant := 14; 189 190 -- Task registers 191 -- K_GET_REGISTERS : constant := 15; 192 -- K_SET_REGISTERS : constant := 16; 193 194 -- These are used to control definable events 195 K_ENABLE_EVENT : constant := 17; 196 K_DISABLE_EVENT : constant := 18; 197 K_ANNOUNCE_EVENT : constant := 19; 198 199 -- These are used to control time-slicing. 200 -- K_SHOW_TIME_SLICE : constant := 20; 201 -- K_SET_TIME_SLICE : constant := 21; 202 203 -- This is used to symbolize task stack addresses. 204 -- K_SYMBOLIZE_ADDRESS : constant := 22; 205 206 K_GET_CALLER : constant := 23; 207 -- This is used to obtain the task value of the caller task 208 209 -- Miscellaneous functions - see below for details 210 211 K_CLEANUP_EVENT : constant := 24; 212 K_SHOW_EVENT_DEF : constant := 25; 213 -- K_CHECK_TASK_STACK : constant := 26; -- why commented out ??? 214 215 -- This is used to obtain the DBGEXT-interface revision level 216 -- K_GET_DBGEXT_REV : constant := 27; -- why commented out ??? 217 218 K_GET_STATE_1 : constant := 28; 219 -- This is used to obtain additional state info, primarily for PCA 220 221 K_FIND_EVENT_BY_CODE : constant := 29; 222 K_FIND_EVENT_BY_NAME : constant := 30; 223 -- These are used to search for user-defined event entries 224 225 -- This is used to stop task schedulding. Why commented out ??? 226 -- K_STOP_ALL_OTHER_TASKS : constant := 31; 227 228 -- Debug event constants 229 230 K_TASK_NOT_EXIST : constant := 3; 231 K_SUCCESS : constant := 1; 232 K_EVENT_SENT : constant := 16#9A#; 233 K_TS_TASK : constant := 18; 234 K_DTYPE_TASK : constant := 44; 235 236 -- Status signal constants 237 238 SS_BADPARAM : constant := 20; 239 SS_NORMAL : constant := 1; 240 241 -- Miscellaneous mask constants 242 243 V_EVNT_ALL : constant := 0; 244 V_Full_Display : constant := 11; 245 V_Suppress_Header : constant := 13; 246 247 -- CMA constants (why are some commented out???) 248 249 CMA_C_DEBGET_GUARDSIZE : constant := 1; 250 CMA_C_DEBGET_IS_HELD : constant := 2; 251-- CMA_C_DEBGET_IS_INITIAL : constant := 3; 252-- CMA_C_DEBGET_NUMBER : constant := 4; 253 CMA_C_DEBGET_STACKPTR : constant := 5; 254 CMA_C_DEBGET_STACK_BASE : constant := 6; 255 CMA_C_DEBGET_STACK_TOP : constant := 7; 256 CMA_C_DEBGET_SCHED_STATE : constant := 8; 257 CMA_C_DEBGET_YELLOWSIZE : constant := 9; 258-- CMA_C_DEBGET_BASE_PRIO : constant := 10; 259-- CMA_C_DEBGET_REGS : constant := 11; 260-- CMA_C_DEBGET_ALT_PENDING : constant := 12; 261-- CMA_C_DEBGET_ALT_A_ENABLE : constant := 13; 262-- CMA_C_DEBGET_ALT_G_ENABLE : constant := 14; 263-- CMA_C_DEBGET_SUBSTATE : constant := 15; 264-- CMA_C_DEBGET_OBJECT_ADDR : constant := 16; 265-- CMA_C_DEBGET_THKIND : constant := 17; 266-- CMA_C_DEBGET_DETACHED : constant := 18; 267 CMA_C_DEBGET_TCB_SIZE : constant := 19; 268-- CMA_C_DEBGET_START_PC : constant := 20; 269-- CMA_C_DEBGET_NEXT_PC : constant := 22; 270-- CMA_C_DEBGET_POLICY : constant := 23; 271-- CMA_C_DEBGET_STACK_YELLOW : constant := 24; 272-- CMA_C_DEBGET_STACK_DEFAULT : constant := 25; 273 274 -- Miscellaneous counted ascii constants 275 276 Star : constant AASCIC := new ASCIC'(2, ("* ")); 277 NoStar : constant AASCIC := new ASCIC'(2, (" ")); 278 Hold : constant AASCIC := new ASCIC'(4, ("HOLD")); 279 NoHold : constant AASCIC := new ASCIC'(4, (" ")); 280 Header : constant AASCIC := new ASCIC ' 281 (60, (" task id pri hold state substate task object")); 282 Empty_Text : constant AASCIC := new ASCIC (0); 283 284 -- DEBUG Ada tasking states equated to their GNAT tasking equivalents 285 286 Ada_State_Invalid_State : constant AASCIC := 287 new ASCIC'(17, "Invalid state "); 288-- Ada_State_Abnormal : constant AASCIC := 289-- new ASCIC'(17, "Abnormal "); 290 Ada_State_Aborting : constant AASCIC := 291 new ASCIC'(17, "Aborting "); -- Aborting (new) 292-- Ada_State_Completed_Abn : constant AASCIC := 293-- new ASCIC'(17, "Completed [abn] "); 294-- Ada_State_Completed_Exc : constant AASCIC := 295-- new ASCIC'(17, "Completed [exc] "); 296 Ada_State_Completed : constant AASCIC := 297 new ASCIC'(17, "Completed "); -- Master_Completion_Sleep 298 Ada_State_Runnable : constant AASCIC := 299 new ASCIC'(17, "Runnable "); -- Runnable 300 Ada_State_Activating : constant AASCIC := 301 new ASCIC'(17, "Activating "); 302 Ada_State_Accept : constant AASCIC := 303 new ASCIC'(17, "Accept "); -- Acceptor_Sleep 304 Ada_State_Select_or_Delay : constant AASCIC := 305 new ASCIC'(17, "Select or delay "); -- Acceptor_Delay_Sleep 306 Ada_State_Select_or_Term : constant AASCIC := 307 new ASCIC'(17, "Select or term. "); -- Terminate_Alternative 308 Ada_State_Select_or_Abort : constant AASCIC := 309 new ASCIC'(17, "Select or abort "); -- Async_Select_Sleep (new) 310-- Ada_State_Select : constant AASCIC := 311-- new ASCIC'(17, "Select "); 312 Ada_State_Activating_Tasks : constant AASCIC := 313 new ASCIC'(17, "Activating tasks "); -- Activator_Sleep 314 Ada_State_Delay : constant AASCIC := 315 new ASCIC'(17, "Delay "); -- AST_Pending 316-- Ada_State_Dependents : constant AASCIC := 317-- new ASCIC'(17, "Dependents "); 318 Ada_State_Entry_Call : constant AASCIC := 319 new ASCIC'(17, "Entry call "); -- Entry_Caller_Sleep 320 Ada_State_Cond_Entry_Call : constant AASCIC := 321 new ASCIC'(17, "Cond. entry call "); -- Call.Mode.Conditional_Call 322 Ada_State_Timed_Entry_Call : constant AASCIC := 323 new ASCIC'(17, "Timed entry call "); -- Call.Mode.Timed_Call 324 Ada_State_Async_Entry_Call : constant AASCIC := 325 new ASCIC'(17, "Async entry call "); -- Call.Mode.Asynchronous_Call (new) 326-- Ada_State_Dependents_Exc : constant AASCIC := 327-- new ASCIC'(17, "Dependents [exc] "); 328 Ada_State_IO_or_AST : constant AASCIC := 329 new ASCIC'(17, "I/O or AST "); -- AST_Server_Sleep 330-- Ada_State_Shared_Resource : constant AASCIC := 331-- new ASCIC'(17, "Shared resource "); 332 Ada_State_Not_Yet_Activated : constant AASCIC := 333 new ASCIC'(17, "Not yet activated"); -- Unactivated 334-- Ada_State_Terminated_Abn : constant AASCIC := 335-- new ASCIC'(17, "Terminated [abn] "); 336-- Ada_State_Terminated_Exc : constant AASCIC := 337-- new ASCIC'(17, "Terminated [exc] "); 338 Ada_State_Terminated : constant AASCIC := 339 new ASCIC'(17, "Terminated "); -- Terminated 340 Ada_State_Server : constant AASCIC := 341 new ASCIC'(17, "Server "); -- Servers 342 Ada_State_Async_Hold : constant AASCIC := 343 new ASCIC'(17, "Async_Hold "); -- Async_Hold 344 345 -- Task state counted ascii constants 346 347 Debug_State_Emp : constant AASCIC := new ASCIC'(5, " "); 348 Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN "); 349 Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY"); 350 Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP "); 351 Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM "); 352 353 -- Priority order of event display 354 355 Global_Event_Display_Order : constant array (Event_Kind_Type) 356 of Event_Kind_Type := ( 357 Debug_Event_Abort_Terminated, 358 Debug_Event_Activating, 359 Debug_Event_Dependents_Exception, 360 Debug_Event_Exception_Terminated, 361 Debug_Event_Handled, 362 Debug_Event_Handled_Others, 363 Debug_Event_Preempted, 364 Debug_Event_Rendezvous_Exception, 365 Debug_Event_Run, 366 Debug_Event_Suspended, 367 Debug_Event_Terminated); 368 369 -- Constant array defining all debug events 370 371 Event_Directory : constant array (Event_Kind_Type) 372 of Debug_Event_Record := ( 373 (Debug_Event_Activating, 374 (False, False, False, False, False, False, False, True), 375 K_EVENT_SENT, 376 K_TS_TASK, 377 K_DTYPE_TASK, 378 0, 379 2, 380 (31, "ACTIVATING "), 381 new ASCIC'(41, "!_a task is about to begin its activation")), 382 383 (Debug_Event_Run, 384 (False, False, False, False, False, False, False, True), 385 K_EVENT_SENT, 386 K_TS_TASK, 387 K_DTYPE_TASK, 388 0, 389 2, 390 (31, "RUN "), 391 new ASCIC'(24, "!_a task is about to run")), 392 393 (Debug_Event_Suspended, 394 (False, False, False, False, False, False, False, True), 395 K_EVENT_SENT, 396 K_TS_TASK, 397 K_DTYPE_TASK, 398 0, 399 1, 400 (31, "SUSPENDED "), 401 new ASCIC'(33, "!_a task is about to be suspended")), 402 403 (Debug_Event_Preempted, 404 (False, False, False, False, False, False, False, True), 405 K_EVENT_SENT, 406 K_TS_TASK, 407 K_DTYPE_TASK, 408 0, 409 1, 410 (31, "PREEMPTED "), 411 new ASCIC'(33, "!_a task is about to be preempted")), 412 413 (Debug_Event_Terminated, 414 (False, False, False, False, False, False, False, True), 415 K_EVENT_SENT, 416 K_TS_TASK, 417 K_DTYPE_TASK, 418 0, 419 1, 420 (31, "TERMINATED "), 421 new ASCIC'(57, 422 "!_a task is terminating (including by abort or exception)")), 423 424 (Debug_Event_Abort_Terminated, 425 (False, False, False, False, False, False, False, True), 426 K_EVENT_SENT, 427 K_TS_TASK, 428 K_DTYPE_TASK, 429 0, 430 2, 431 (31, "ABORT_TERMINATED "), 432 new ASCIC'(40, "!_a task is terminating because of abort")), 433 434 (Debug_Event_Exception_Terminated, 435 (False, False, False, False, False, False, False, True), 436 K_EVENT_SENT, 437 K_TS_TASK, 438 K_DTYPE_TASK, 439 0, 440 1, 441 (31, "EXCEPTION_TERMINATED "), 442 new ASCIC'(47, "!_a task is terminating because of an exception")), 443 444 (Debug_Event_Rendezvous_Exception, 445 (False, False, False, False, False, False, False, True), 446 K_EVENT_SENT, 447 K_TS_TASK, 448 K_DTYPE_TASK, 449 0, 450 3, 451 (31, "RENDEZVOUS_EXCEPTION "), 452 new ASCIC'(49, "!_an exception is propagating out of a rendezvous")), 453 454 (Debug_Event_Handled, 455 (False, False, False, False, False, False, False, True), 456 K_EVENT_SENT, 457 K_TS_TASK, 458 K_DTYPE_TASK, 459 0, 460 1, 461 (31, "HANDLED "), 462 new ASCIC'(37, "!_an exception is about to be handled")), 463 464 (Debug_Event_Dependents_Exception, 465 (False, False, False, False, False, False, False, True), 466 K_EVENT_SENT, 467 K_TS_TASK, 468 K_DTYPE_TASK, 469 0, 470 1, 471 (31, "DEPENDENTS_EXCEPTION "), 472 new ASCIC'(64, 473 "!_an exception is about to cause a task to await dependent tasks")), 474 475 (Debug_Event_Handled_Others, 476 (False, False, False, False, False, False, False, True), 477 K_EVENT_SENT, 478 K_TS_TASK, 479 K_DTYPE_TASK, 480 0, 481 1, 482 (31, "HANDLED_OTHERS "), 483 new ASCIC'(58, 484 "!_an exception is about to be handled in an OTHERS handler"))); 485 486 -- Help on events displayed in DEBUG 487 488 Event_Def_Help : constant AASCIC_Array := ( 489 new ASCIC'(0, ""), 490 new ASCIC'(65, 491 " The general forms of commands to set a breakpoint or tracepoint"), 492 new ASCIC'(22, " on an Ada event are:"), 493 new ASCIC'(73, " SET BREAK/EVENT=event [task[, ... ]] " & 494 "[WHEN(expr)] [DO(comnd[; ... ])]"), 495 new ASCIC'(73, " SET TRACE/EVENT=event [task[, ... ]] " & 496 "[WHEN(expr)] [DO(comnd[; ... ])]"), 497 new ASCIC'(0, ""), 498 new ASCIC'(65, 499 " If tasks are specified, the breakpoint will trigger only if the"), 500 new ASCIC'(40, " event occurs for those specific tasks."), 501 new ASCIC'(0, ""), 502 new ASCIC'(39, " Ada event names and their definitions"), 503 new ASCIC'(0, "")); 504 505 ----------------------- 506 -- Package Variables -- 507 ----------------------- 508 509 AC_Buffer : ASCIC127; 510 511 Events_Enabled_Count : Integer := 0; 512 513 Print_Routine_Bufsiz : constant := 132; 514 Print_Routine_Bufcnt : Integer := 0; 515 Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz); 516 517 Global_Task_Debug_Events : Debug_Event_Array := 518 (False, False, False, False, False, False, False, False, 519 False, False, False, False, False, False, False, False); 520 -- Global table of task debug events set by the debugger 521 522 -------------------------- 523 -- Exported Subprograms -- 524 -------------------------- 525 526 procedure Default_Print_Routine 527 (Print_Function : Print_Functions; 528 Print_Subfunction : Print_Functions; 529 P1 : Unsigned_Longword := 0; 530 P2 : Unsigned_Longword := 0; 531 P3 : Unsigned_Longword := 0; 532 P4 : Unsigned_Longword := 0; 533 P5 : Unsigned_Longword := 0; 534 P6 : Unsigned_Longword := 0); 535 -- The default print routine if not overridden. 536 -- Print_Function determines option argument formatting. 537 -- Print_Subfunction buffers output if No_Print, calls Put_Output if 538 -- Print_Newline 539 540 pragma Export_Procedure 541 (Default_Print_Routine, 542 Mechanism => (Value, Value, Reference, Reference, Reference)); 543 544 -------------------------- 545 -- Imported Subprograms -- 546 -------------------------- 547 548 procedure Debug_Get 549 (Thread_Id : OSI.Thread_Id; 550 Item_Req : Unsigned_Word; 551 Out_Buff : System.Address; 552 Buff_Siz : Unsigned_Word); 553 554 procedure Debug_Get 555 (Thread_Id : OSI.Thread_Id; 556 Item_Req : Unsigned_Word; 557 Out_Buff : Unsigned_Longword; 558 Buff_Siz : Unsigned_Word); 559 pragma Import (External, Debug_Get); 560 561 pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", 562 (OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word), 563 (Reference, Value, Reference, Value)); 564 565 pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", 566 (OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word), 567 (Reference, Value, Reference, Value)); 568 569 procedure FAOL 570 (Status : out Cond_Value_Type; 571 Ctrstr : String; 572 Outlen : out Unsigned_Word; 573 Outbuf : out String; 574 Prmlst : Unsigned_Longword_Array); 575 pragma Import (External, FAOL); 576 577 pragma Import_Valued_Procedure (FAOL, "SYS$FAOL", 578 (Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array), 579 (Value, Descriptor (S), Reference, Descriptor (S), Reference)); 580 581 procedure Put_Output ( 582 Status : out Cond_Value_Type; 583 Message_String : String); 584 585 procedure Put_Output (Message_String : String); 586 pragma Import (External, Put_Output); 587 588 pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT", 589 (Cond_Value_Type, String), 590 (Value, Short_Descriptor (S))); 591 592 pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT", 593 (String), 594 (Short_Descriptor (S))); 595 596 procedure Signal 597 (Condition_Value : Cond_Value_Type; 598 Number_Of_Arguments : Integer := Integer'Null_Parameter; 599 FAO_Argument_1 : Unsigned_Longword := 600 Unsigned_Longword'Null_Parameter); 601 pragma Import (External, Signal); 602 603 pragma Import_Procedure (Signal, "LIB$SIGNAL", 604 (Cond_Value_Type, Integer, Unsigned_Longword), 605 (Value, Value, Value), 606 Number_Of_Arguments); 607 608 ---------------------------- 609 -- Generic Instantiations -- 610 ---------------------------- 611 612 function Fetch is new Fetch_From_Address (Unsigned_Longword); 613 pragma Unreferenced (Fetch); 614 615 procedure Free is new Ada.Unchecked_Deallocation 616 (Object => Ada_Event_Control_Block_Type, 617 Name => Ada_Event_Control_Block_Access); 618 619 function To_AASCIC is new 620 Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC); 621 622 function To_Addr is new 623 Ada.Unchecked_Conversion (Task_Procedure_Access, Address); 624 pragma Unreferenced (To_Addr); 625 626 function To_EVCB is new 627 Ada.Unchecked_Conversion 628 (Unsigned_Longword, Ada_Event_Control_Block_Access); 629 630 function To_Integer is new 631 Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); 632 633 function To_Print_Routine_Type is new 634 Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type); 635 636 -- Optional argumements passed to Print_Routine have to be 637 -- Unsigned_Longwords so define the required Unchecked_Conversions 638 639 function To_UL is new 640 Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword); 641 642 function To_UL is new 643 Ada.Unchecked_Conversion (Integer, Unsigned_Longword); 644 645 function To_UL is new 646 Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); 647 648 pragma Warnings (Off); -- Different sizes 649 function To_UL is new 650 Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword); 651 pragma Warnings (On); 652 653 function To_UL is new 654 Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); 655 656 function To_UL is new 657 Ada.Unchecked_Conversion 658 (Ada_Event_Control_Block_Access, Unsigned_Longword); 659 660 ----------------------- 661 -- Local Subprograms -- 662 ----------------------- 663 664 subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31; 665 -- The 31 function codes sent by the debugger needed to implement 666 -- tasking support, enumerated below. 667 668 type Register_Array is array (Natural range 0 .. 16) of 669 System.Aux_DEC.Unsigned_Longword; 670 -- The register array is a holdover from VAX and not used 671 -- on Alpha or I64 but is kept as a filler below. 672 673 type DBGEXT_Control_Block (Function_Code : Function_Codes) is record 674 Facility_ID : System.Aux_DEC.Unsigned_Word; 675 -- For GNAT use the "Ada" facility ID 676 Status : System.Aux_DEC.Unsigned_Longword; 677 -- Successful or otherwise returned status 678 Flags : System.Aux_DEC.Bit_Array_32; 679 -- Used to flag event as global 680 Print_Routine : System.Aux_DEC.Short_Address; 681 -- The print subprogram the caller wants to use for output 682 Event_Code_or_EVCB : System.Aux_DEC.Unsigned_Longword; 683 -- Dual use Event Code or EVent Control Block 684 Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword; 685 -- Dual use Event Value or Event Name string pointer 686 Event_Entry : System.Aux_DEC.Unsigned_Longword; 687 Task_Value : Task_Id; 688 Task_Number : Integer; 689 Ada_Flags : System.Aux_DEC.Bit_Array_32; 690 Priority : System.Aux_DEC.Bit_Array_32; 691 Active_Registers : System.Aux_DEC.Short_Address; 692 693 case Function_Code is 694 when K_GET_STATE_1 => 695 Base_Priority : System.Aux_DEC.Bit_Array_32; 696 Task_Type_Name : System.Aux_DEC.Short_Address; 697 Creation_PC : System.Aux_DEC.Short_Address; 698 Parent_Task_ID : Task_Id; 699 700 when others => 701 Ignored_Unused : Register_Array; 702 703 end case; 704 end record; 705 706 for DBGEXT_Control_Block use record 707 Function_Code at 0 range 0 .. 15; 708 Facility_ID at 2 range 0 .. 15; 709 Status at 4 range 0 .. 31; 710 Flags at 8 range 0 .. 31; 711 Print_Routine at 12 range 0 .. 31; 712 Event_Code_or_EVCB at 16 range 0 .. 31; 713 Event_Value_or_Name at 20 range 0 .. 31; 714 Event_Entry at 24 range 0 .. 31; 715 Task_Value at 28 range 0 .. 31; 716 Task_Number at 32 range 0 .. 31; 717 Ada_Flags at 36 range 0 .. 31; 718 Priority at 40 range 0 .. 31; 719 Active_Registers at 44 range 0 .. 31; 720 Ignored_Unused at 48 range 0 .. 17 * 32 - 1; 721 Base_Priority at 48 range 0 .. 31; 722 Task_Type_Name at 52 range 0 .. 31; 723 Creation_PC at 56 range 0 .. 31; 724 Parent_Task_ID at 60 range 0 .. 31; 725 end record; 726 727 type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block; 728 729 function DBGEXT (Control_Block : DBGEXT_Control_Block_Access) 730 return System.Aux_DEC.Unsigned_Word; 731 -- Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads 732 pragma Convention (C, DBGEXT); 733 pragma Export_Function (DBGEXT, "GNAT$DBGEXT"); 734 -- This routine is called by CMA when VMS DEBUG wants the Gnat RTL 735 -- to give it some assistance (primarily when tasks are debugged). 736 -- 737 -- The single parameter is an "external control block". On input to 738 -- the Gnat RTL this control block determines the debugging function 739 -- to be performed, and supplies parameters. This routine cases on 740 -- the function code, and calls the appropriate Gnat RTL routine, 741 -- which returns values by modifying the external control block. 742 743 procedure Announce_Event 744 (Event_EVCB : Unsigned_Longword; 745 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); 746 -- Announce the occurence of a DEBUG tasking event 747 748 procedure Cleanup_Event (Event_EVCB : Unsigned_Longword); 749 -- After DEBUG has processed an event that has signalled, the signaller 750 -- must cleanup. Cleanup consists of freeing the event control block. 751 752 procedure Disable_Event 753 (Flags : Bit_Array_32; 754 Event_Value : Unsigned_Longword; 755 Event_Code : Unsigned_Longword; 756 Status : out Cond_Value_Type); 757 -- Disable a DEBUG tasking event 758 759 function DoAC (S : String) return Address; 760 -- Convert a string to the address of an internal buffer containing 761 -- the counted ASCII. 762 763 procedure Enable_Event 764 (Flags : Bit_Array_32; 765 Event_Value : Unsigned_Longword; 766 Event_Code : Unsigned_Longword; 767 Status : out Cond_Value_Type); 768 -- Enable a requested DEBUG tasking event 769 770 procedure Find_Event_By_Code 771 (Event_Code : Unsigned_Longword; 772 Event_Entry : out Unsigned_Longword; 773 Status : out Cond_Value_Type); 774 -- Convert an event code to the address of the event entry 775 776 procedure Find_Event_By_Name 777 (Event_Name : Unsigned_Longword; 778 Event_Entry : out Unsigned_Longword; 779 Status : out Cond_Value_Type); 780 -- Find an event entry given the event name 781 782 procedure List_Entry_Waiters 783 (Task_Value : Task_Id; 784 Full_Display : Boolean := False; 785 Suppress_Header : Boolean := False; 786 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); 787 -- List information about tasks waiting on an entry 788 789 procedure Put (S : String); 790 -- Display S on standard output 791 792 procedure Put_Line (S : String := ""); 793 -- Display S on standard output with an additional line terminator 794 795 procedure Show_Event 796 (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); 797 -- Show what events are available 798 799 procedure Show_One_Task 800 (Task_Value : Task_Id; 801 Full_Display : Boolean := False; 802 Suppress_Header : Boolean := False; 803 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); 804 -- Display information about one task 805 806 procedure Show_Rendezvous 807 (Task_Value : Task_Id; 808 Ada_State : AASCIC := Empty_Text; 809 Full_Display : Boolean := False; 810 Suppress_Header : Boolean := False; 811 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); 812 -- Display information about a task rendezvous 813 814 procedure Trace_Output (Message_String : String); 815 -- Call Put_Output if Trace_on ("VMS") 816 817 procedure Write (Fd : Integer; S : String; Count : Integer); 818 819 -------------------- 820 -- Announce_Event -- 821 -------------------- 822 823 procedure Announce_Event 824 (Event_EVCB : Unsigned_Longword; 825 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) 826 is 827 EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); 828 829 Event_Kind : constant Event_Kind_Type := 830 (if EVCB.Sub_Event /= 0 831 then Event_Kind_Type (EVCB.Sub_Event) 832 else Event_Kind_Type (EVCB.Code)); 833 834 TI : constant String := " Task %TASK !UI is "; 835 -- Announce prefix 836 837 begin 838 Trace_Output ("Announce called"); 839 840 case Event_Kind is 841 when Debug_Event_Activating => 842 Print_Routine (Print_FAO, Print_Newline, 843 To_UL (DoAC (TI & "about to begin its activation")), 844 EVCB.Value); 845 when Debug_Event_Exception_Terminated => 846 Print_Routine (Print_FAO, Print_Newline, 847 To_UL (DoAC (TI & "terminating because of an exception")), 848 EVCB.Value); 849 when Debug_Event_Run => 850 Print_Routine (Print_FAO, Print_Newline, 851 To_UL (DoAC (TI & "about to run")), 852 EVCB.Value); 853 when Debug_Event_Abort_Terminated => 854 Print_Routine (Print_FAO, Print_Newline, 855 To_UL (DoAC (TI & "terminating because of abort")), 856 EVCB.Value); 857 when Debug_Event_Terminated => 858 Print_Routine (Print_FAO, Print_Newline, 859 To_UL (DoAC (TI & "terminating normally")), 860 EVCB.Value); 861 when others => null; 862 end case; 863 end Announce_Event; 864 865 ------------------- 866 -- Cleanup_Event -- 867 ------------------- 868 869 procedure Cleanup_Event (Event_EVCB : Unsigned_Longword) is 870 EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); 871 begin 872 Free (EVCB); 873 end Cleanup_Event; 874 875 ------------------------ 876 -- Continue_All_Tasks -- 877 ------------------------ 878 879 procedure Continue_All_Tasks is 880 begin 881 null; -- VxWorks 882 end Continue_All_Tasks; 883 884 ------------ 885 -- DBGEXT -- 886 ------------ 887 888 function DBGEXT 889 (Control_Block : DBGEXT_Control_Block_Access) 890 return System.Aux_DEC.Unsigned_Word 891 is 892 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access; 893 begin 894 Trace_Output ("DBGEXT called"); 895 896 if Control_Block.Print_Routine /= Address_Zero then 897 Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine); 898 end if; 899 900 case Control_Block.Function_Code is 901 902 -- Convert a task value to a task number. 903 -- The output results are stored in the CONTROL_BLOCK. 904 905 when K_CVT_VALUE_NUM => 906 Trace_Output ("DBGEXT param 1 - CVT Value to NUM"); 907 Control_Block.Task_Number := 908 Control_Block.Task_Value.Known_Tasks_Index + 1; 909 Control_Block.Status := K_SUCCESS; 910 Trace_Output ("Task Number: "); 911 Trace_Output (Integer'Image (Control_Block.Task_Number)); 912 return SS_NORMAL; 913 914 -- Convert a task number to a task value. 915 -- The output results are stored in the CONTROL_BLOCK. 916 917 when K_CVT_NUM_VALUE => 918 Trace_Output ("DBGEXT param 2 - CVT NUM to Value"); 919 Trace_Output ("Task Number: "); 920 Trace_Output (Integer'Image (Control_Block.Task_Number)); 921 Control_Block.Task_Value := 922 Known_Tasks (Control_Block.Task_Number - 1); 923 Control_Block.Status := K_SUCCESS; 924 Trace_Output ("Task Value: "); 925 Trace_Output (Unsigned_Longword'Image 926 (To_UL (Control_Block.Task_Value))); 927 return SS_NORMAL; 928 929 -- Obtain the "next" task after a specified task. 930 -- ??? To do: If specified check the PRIORITY, STATE, and HOLD 931 -- fields to restrict the selection of the next task. 932 -- The output results are stored in the CONTROL_BLOCK. 933 934 when K_NEXT_TASK => 935 Trace_Output ("DBGEXT param 3 - Next Task"); 936 Trace_Output ("Task Value: "); 937 Trace_Output (Unsigned_Longword'Image 938 (To_UL (Control_Block.Task_Value))); 939 940 if Control_Block.Task_Value = null then 941 Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); 942 else 943 Control_Block.Task_Value := 944 Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1); 945 end if; 946 947 if Control_Block.Task_Value = null then 948 Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); 949 end if; 950 951 Control_Block.Status := K_SUCCESS; 952 return SS_NORMAL; 953 954 -- Display the state of a task. The FULL bit is checked to decide if 955 -- a full or brief task display is desired. The output results are 956 -- stored in the CONTROL_BLOCK. 957 958 when K_SHOW_TASK => 959 Trace_Output ("DBGEXT param 4 - Show Task"); 960 961 if Control_Block.Task_Value = null then 962 Control_Block.Status := K_TASK_NOT_EXIST; 963 else 964 Show_One_Task 965 (Control_Block.Task_Value, 966 Control_Block.Ada_Flags (V_Full_Display), 967 Control_Block.Ada_Flags (V_Suppress_Header), 968 Print_Routine); 969 970 Control_Block.Status := K_SUCCESS; 971 end if; 972 973 return SS_NORMAL; 974 975 -- Enable a requested DEBUG tasking event 976 977 when K_ENABLE_EVENT => 978 Trace_Output ("DBGEXT param 17 - Enable Event"); 979 Enable_Event 980 (Control_Block.Flags, 981 Control_Block.Event_Value_or_Name, 982 Control_Block.Event_Code_or_EVCB, 983 Control_Block.Status); 984 985 return SS_NORMAL; 986 987 -- Disable a DEBUG tasking event 988 989 when K_DISABLE_EVENT => 990 Trace_Output ("DBGEXT param 18 - Disable Event"); 991 Disable_Event 992 (Control_Block.Flags, 993 Control_Block.Event_Value_or_Name, 994 Control_Block.Event_Code_or_EVCB, 995 Control_Block.Status); 996 997 return SS_NORMAL; 998 999 -- Announce the occurence of a DEBUG tasking event 1000 1001 when K_ANNOUNCE_EVENT => 1002 Trace_Output ("DBGEXT param 19 - Announce Event"); 1003 Announce_Event 1004 (Control_Block.Event_Code_or_EVCB, 1005 Print_Routine); 1006 1007 Control_Block.Status := K_SUCCESS; 1008 return SS_NORMAL; 1009 1010 -- After DEBUG has processed an event that has signalled, 1011 -- the signaller must cleanup. 1012 -- Cleanup consists of freeing the event control block. 1013 1014 when K_CLEANUP_EVENT => 1015 Trace_Output ("DBGEXT param 24 - Cleanup Event"); 1016 Cleanup_Event (Control_Block.Event_Code_or_EVCB); 1017 1018 Control_Block.Status := K_SUCCESS; 1019 return SS_NORMAL; 1020 1021 -- Show what events are available 1022 1023 when K_SHOW_EVENT_DEF => 1024 Trace_Output ("DBGEXT param 25 - Show Event Def"); 1025 Show_Event (Print_Routine); 1026 1027 Control_Block.Status := K_SUCCESS; 1028 return SS_NORMAL; 1029 1030 -- Convert an event code to the address of the event entry 1031 1032 when K_FIND_EVENT_BY_CODE => 1033 Trace_Output ("DBGEXT param 29 - Find Event by Code"); 1034 Find_Event_By_Code 1035 (Control_Block.Event_Code_or_EVCB, 1036 Control_Block.Event_Entry, 1037 Control_Block.Status); 1038 1039 return SS_NORMAL; 1040 1041 -- Find an event entry given the event name 1042 1043 when K_FIND_EVENT_BY_NAME => 1044 Trace_Output ("DBGEXT param 30 - Find Event by Name"); 1045 Find_Event_By_Name 1046 (Control_Block.Event_Value_or_Name, 1047 Control_Block.Event_Entry, 1048 Control_Block.Status); 1049 return SS_NORMAL; 1050 1051 -- ??? To do: Implement priority events 1052 -- Get, set or restore a task's priority 1053 1054 when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY => 1055 Trace_Output ("DBGEXT priority param - Not yet implemented"); 1056 Trace_Output (Function_Codes'Image 1057 (Control_Block.Function_Code)); 1058 return SS_BADPARAM; 1059 1060 -- ??? To do: Implement show statistics event 1061 -- Display task statistics 1062 1063 when K_SHOW_STAT => 1064 Trace_Output ("DBGEXT show stat param - Not yet implemented"); 1065 Trace_Output (Function_Codes'Image 1066 (Control_Block.Function_Code)); 1067 return SS_BADPARAM; 1068 1069 -- ??? To do: Implement get caller event 1070 -- Obtain the caller of a task in a rendezvous. If no rendezvous, 1071 -- null is returned 1072 1073 when K_GET_CALLER => 1074 Trace_Output ("DBGEXT get caller param - Not yet implemented"); 1075 Trace_Output (Function_Codes'Image 1076 (Control_Block.Function_Code)); 1077 return SS_BADPARAM; 1078 1079 -- ??? To do: Implement set terminate event 1080 -- Terminate a task 1081 1082 when K_SET_ABORT => 1083 Trace_Output ("DBGEXT set terminate param - Not yet implemented"); 1084 Trace_Output (Function_Codes'Image 1085 (Control_Block.Function_Code)); 1086 return SS_BADPARAM; 1087 1088 -- ??? To do: Implement show deadlock event 1089 -- Detect a deadlock 1090 1091 when K_SHOW_DEADLOCK => 1092 Trace_Output ("DBGEXT show deadlock param - Not yet implemented"); 1093 Trace_Output (Function_Codes'Image 1094 (Control_Block.Function_Code)); 1095 return SS_BADPARAM; 1096 1097 when others => 1098 Trace_Output ("DBGEXT bad param: "); 1099 Trace_Output (Function_Codes'Image 1100 (Control_Block.Function_Code)); 1101 return SS_BADPARAM; 1102 1103 end case; 1104 end DBGEXT; 1105 1106 --------------------------- 1107 -- Default_Print_Routine -- 1108 --------------------------- 1109 1110 procedure Default_Print_Routine 1111 (Print_Function : Print_Functions; 1112 Print_Subfunction : Print_Functions; 1113 P1 : Unsigned_Longword := 0; 1114 P2 : Unsigned_Longword := 0; 1115 P3 : Unsigned_Longword := 0; 1116 P4 : Unsigned_Longword := 0; 1117 P5 : Unsigned_Longword := 0; 1118 P6 : Unsigned_Longword := 0) 1119 is 1120 Status : Cond_Value_Type; 1121 Linlen : Unsigned_Word; 1122 Item_List : Unsigned_Longword_Array (1 .. 17) := 1123 (1 .. 17 => 0); 1124 begin 1125 1126 case Print_Function is 1127 when Print_Control | Print_String => 1128 null; 1129 1130 -- Formatted Ascii Output 1131 1132 when Print_FAO => 1133 Item_List (1) := P2; 1134 Item_List (2) := P3; 1135 Item_List (3) := P4; 1136 Item_List (4) := P5; 1137 Item_List (5) := P6; 1138 FAOL 1139 (Status, 1140 To_AASCIC (P1).Text, 1141 Linlen, 1142 Print_Routine_Linbuf 1143 (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), 1144 Item_List); 1145 1146 Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); 1147 1148 -- Symbolic output 1149 1150 when Print_Symbol => 1151 Item_List (1) := P1; 1152 FAOL 1153 (Status, 1154 "!XI", 1155 Linlen, 1156 Print_Routine_Linbuf 1157 (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), 1158 Item_List); 1159 1160 Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); 1161 1162 when others => 1163 null; 1164 end case; 1165 1166 case Print_Subfunction is 1167 1168 -- Output buffer with a terminating newline 1169 1170 when Print_Newline => 1171 Put_Output (Status, 1172 Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt)); 1173 Print_Routine_Bufcnt := 0; 1174 1175 -- Buffer the output 1176 1177 when No_Print => 1178 null; 1179 1180 when others => 1181 null; 1182 end case; 1183 1184 end Default_Print_Routine; 1185 1186 ------------------- 1187 -- Disable_Event -- 1188 ------------------- 1189 1190 procedure Disable_Event 1191 (Flags : Bit_Array_32; 1192 Event_Value : Unsigned_Longword; 1193 Event_Code : Unsigned_Longword; 1194 Status : out Cond_Value_Type) 1195 is 1196 Task_Value : Task_Id; 1197 Task_Index : constant Integer := Integer (Event_Value) - 1; 1198 begin 1199 1200 Events_Enabled_Count := Events_Enabled_Count - 1; 1201 1202 if Flags (V_EVNT_ALL) then 1203 Global_Task_Debug_Events (Integer (Event_Code)) := False; 1204 Status := K_SUCCESS; 1205 else 1206 if Task_Index in Known_Tasks'Range then 1207 Task_Value := Known_Tasks (Task_Index); 1208 if Task_Value /= null then 1209 Task_Value.Common.Debug_Events (Integer (Event_Code)) := False; 1210 Status := K_SUCCESS; 1211 else 1212 Status := K_TASK_NOT_EXIST; 1213 end if; 1214 else 1215 Status := K_TASK_NOT_EXIST; 1216 end if; 1217 end if; 1218 1219 -- Keep count of events for efficiency 1220 1221 if Events_Enabled_Count <= 0 then 1222 Events_Enabled_Count := 0; 1223 Global_Task_Debug_Event_Set := False; 1224 end if; 1225 1226 end Disable_Event; 1227 1228 ---------- 1229 -- DoAC -- 1230 ---------- 1231 1232 function DoAC (S : String) return Address is 1233 begin 1234 AC_Buffer.Count := S'Length; 1235 AC_Buffer.Text (1 .. AC_Buffer.Count) := S; 1236 return AC_Buffer'Address; 1237 end DoAC; 1238 1239 ------------------ 1240 -- Enable_Event -- 1241 ------------------ 1242 1243 procedure Enable_Event 1244 (Flags : Bit_Array_32; 1245 Event_Value : Unsigned_Longword; 1246 Event_Code : Unsigned_Longword; 1247 Status : out Cond_Value_Type) 1248 is 1249 Task_Value : Task_Id; 1250 Task_Index : constant Integer := Integer (Event_Value) - 1; 1251 1252 begin 1253 -- At least one event enabled, any and all events will cause a 1254 -- condition to be raised and checked. Major tasking slowdown. 1255 1256 Global_Task_Debug_Event_Set := True; 1257 Events_Enabled_Count := Events_Enabled_Count + 1; 1258 1259 if Flags (V_EVNT_ALL) then 1260 Global_Task_Debug_Events (Integer (Event_Code)) := True; 1261 Status := K_SUCCESS; 1262 else 1263 if Task_Index in Known_Tasks'Range then 1264 Task_Value := Known_Tasks (Task_Index); 1265 if Task_Value /= null then 1266 Task_Value.Common.Debug_Events (Integer (Event_Code)) := True; 1267 Status := K_SUCCESS; 1268 else 1269 Status := K_TASK_NOT_EXIST; 1270 end if; 1271 else 1272 Status := K_TASK_NOT_EXIST; 1273 end if; 1274 end if; 1275 1276 end Enable_Event; 1277 1278 ------------------------ 1279 -- Find_Event_By_Code -- 1280 ------------------------ 1281 1282 procedure Find_Event_By_Code 1283 (Event_Code : Unsigned_Longword; 1284 Event_Entry : out Unsigned_Longword; 1285 Status : out Cond_Value_Type) 1286 is 1287 K_SUCCESS : constant := 1; 1288 K_NO_SUCH_EVENT : constant := 9; 1289 1290 begin 1291 Trace_Output ("Looking for Event: "); 1292 Trace_Output (Unsigned_Longword'Image (Event_Code)); 1293 1294 for I in Event_Kind_Type'Range loop 1295 if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then 1296 Event_Entry := To_UL (Event_Directory (I)'Address); 1297 Trace_Output ("Found Event # "); 1298 Trace_Output (Integer'Image (I)); 1299 Status := K_SUCCESS; 1300 return; 1301 end if; 1302 end loop; 1303 1304 Status := K_NO_SUCH_EVENT; 1305 end Find_Event_By_Code; 1306 1307 ------------------------ 1308 -- Find_Event_By_Name -- 1309 ------------------------ 1310 1311 procedure Find_Event_By_Name 1312 (Event_Name : Unsigned_Longword; 1313 Event_Entry : out Unsigned_Longword; 1314 Status : out Cond_Value_Type) 1315 is 1316 K_SUCCESS : constant := 1; 1317 K_NO_SUCH_EVENT : constant := 9; 1318 1319 Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all; 1320 begin 1321 Trace_Output ("Looking for Event: "); 1322 Trace_Output (Event_Name_Cstr.Text); 1323 1324 for I in Event_Kind_Type'Range loop 1325 if Event_Name_Cstr.Count >= Event_Directory (I).Minchr 1326 and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count 1327 and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) = 1328 Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr) 1329 then 1330 Event_Entry := To_UL (Event_Directory (I)'Address); 1331 Trace_Output ("Found Event # "); 1332 Trace_Output (Integer'Image (I)); 1333 Status := K_SUCCESS; 1334 return; 1335 end if; 1336 end loop; 1337 1338 Status := K_NO_SUCH_EVENT; 1339 end Find_Event_By_Name; 1340 1341 -------------------- 1342 -- Get_User_State -- 1343 -------------------- 1344 1345 function Get_User_State return Long_Integer is 1346 begin 1347 return STPO.Self.User_State; 1348 end Get_User_State; 1349 1350 ------------------------ 1351 -- List_Entry_Waiters -- 1352 ------------------------ 1353 1354 procedure List_Entry_Waiters 1355 (Task_Value : Task_Id; 1356 Full_Display : Boolean := False; 1357 Suppress_Header : Boolean := False; 1358 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) 1359 is 1360 pragma Unreferenced (Suppress_Header); 1361 1362 Entry_Call : Entry_Call_Link; 1363 Have_Some : Boolean := False; 1364 begin 1365 if not Full_Display then 1366 return; 1367 end if; 1368 1369 if Task_Value.Entry_Queues'Length > 0 then 1370 Print_Routine (Print_FAO, Print_Newline, 1371 To_UL (DoAC (" Waiting entry callers:"))); 1372 end if; 1373 for I in Task_Value.Entry_Queues'Range loop 1374 Entry_Call := Task_Value.Entry_Queues (I).Head; 1375 if Entry_Call /= null then 1376 Have_Some := True; 1377 1378 Print_Routine (Print_FAO, Print_Newline, 1379 To_UL (DoAC (" Waiters for entry !UI:")), 1380 To_UL (I)); 1381 1382 loop 1383 declare 1384 Task_Image : ASCIC := 1385 (Entry_Call.Self.Common.Task_Image_Len, 1386 Entry_Call.Self.Common.Task_Image 1387 (1 .. Entry_Call.Self.Common.Task_Image_Len)); 1388 begin 1389 Print_Routine (Print_FAO, Print_Newline, 1390 To_UL (DoAC (" %TASK !UI, type: !AC")), 1391 To_UL (Entry_Call.Self.Known_Tasks_Index + 1), 1392 To_UL (Task_Image'Address)); 1393 if Entry_Call = Task_Value.Entry_Queues (I).Tail then 1394 exit; 1395 end if; 1396 Entry_Call := Entry_Call.Next; 1397 end; 1398 end loop; 1399 end if; 1400 end loop; 1401 if not Have_Some then 1402 Print_Routine (Print_FAO, Print_Newline, 1403 To_UL (DoAC (" none."))); 1404 end if; 1405 end List_Entry_Waiters; 1406 1407 ---------------- 1408 -- List_Tasks -- 1409 ---------------- 1410 1411 procedure List_Tasks is 1412 C : Task_Id; 1413 begin 1414 C := All_Tasks_List; 1415 1416 while C /= null loop 1417 Print_Task_Info (C); 1418 C := C.Common.All_Tasks_Link; 1419 end loop; 1420 end List_Tasks; 1421 1422 ------------------------ 1423 -- Print_Current_Task -- 1424 ------------------------ 1425 1426 procedure Print_Current_Task is 1427 begin 1428 Print_Task_Info (STPO.Self); 1429 end Print_Current_Task; 1430 1431 --------------------- 1432 -- Print_Task_Info -- 1433 --------------------- 1434 1435 procedure Print_Task_Info (T : Task_Id) is 1436 Entry_Call : Entry_Call_Link; 1437 Parent : Task_Id; 1438 1439 begin 1440 if T = null then 1441 Put_Line ("null task"); 1442 return; 1443 end if; 1444 1445 Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " & 1446 Task_States'Image (T.Common.State)); 1447 1448 Parent := T.Common.Parent; 1449 1450 if Parent = null then 1451 Put (", parent: <none>"); 1452 else 1453 Put (", parent: " & 1454 Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len)); 1455 end if; 1456 1457 Put (", prio:" & T.Common.Current_Priority'Img); 1458 1459 if not T.Callable then 1460 Put (", not callable"); 1461 end if; 1462 1463 if T.Aborting then 1464 Put (", aborting"); 1465 end if; 1466 1467 if T.Deferral_Level /= 0 then 1468 Put (", abort deferred"); 1469 end if; 1470 1471 if T.Common.Call /= null then 1472 Entry_Call := T.Common.Call; 1473 Put (", serving:"); 1474 1475 while Entry_Call /= null loop 1476 Put (To_Integer (Entry_Call.Self)'Img); 1477 Entry_Call := Entry_Call.Acceptor_Prev_Call; 1478 end loop; 1479 end if; 1480 1481 if T.Open_Accepts /= null then 1482 Put (", accepting:"); 1483 1484 for J in T.Open_Accepts'Range loop 1485 Put (T.Open_Accepts (J).S'Img); 1486 end loop; 1487 1488 if T.Terminate_Alternative then 1489 Put (" or terminate"); 1490 end if; 1491 end if; 1492 1493 if T.User_State /= 0 then 1494 Put (", state:" & T.User_State'Img); 1495 end if; 1496 1497 Put_Line; 1498 end Print_Task_Info; 1499 1500 --------- 1501 -- Put -- 1502 --------- 1503 1504 procedure Put (S : String) is 1505 begin 1506 Write (2, S, S'Length); 1507 end Put; 1508 1509 -------------- 1510 -- Put_Line -- 1511 -------------- 1512 1513 procedure Put_Line (S : String := "") is 1514 begin 1515 Write (2, S & ASCII.LF, S'Length + 1); 1516 end Put_Line; 1517 1518 ---------------------- 1519 -- Resume_All_Tasks -- 1520 ---------------------- 1521 1522 procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is 1523 pragma Unreferenced (Thread_Self); 1524 begin 1525 null; -- VxWorks 1526 end Resume_All_Tasks; 1527 1528 --------------- 1529 -- Set_Trace -- 1530 --------------- 1531 1532 procedure Set_Trace (Flag : Character; Value : Boolean := True) is 1533 begin 1534 Trace_On (Flag) := Value; 1535 end Set_Trace; 1536 1537 -------------------- 1538 -- Set_User_State -- 1539 -------------------- 1540 1541 procedure Set_User_State (Value : Long_Integer) is 1542 begin 1543 STPO.Self.User_State := Value; 1544 end Set_User_State; 1545 1546 ---------------- 1547 -- Show_Event -- 1548 ---------------- 1549 1550 procedure Show_Event 1551 (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) 1552 is 1553 begin 1554 for I in Event_Def_Help'Range loop 1555 Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I))); 1556 end loop; 1557 1558 for I in Event_Kind_Type'Range loop 1559 Print_Routine (Print_FAO, Print_Newline, 1560 To_UL (Event_Directory 1561 (Global_Event_Display_Order (I)).Name'Address)); 1562 Print_Routine (Print_FAO, Print_Newline, 1563 To_UL (Event_Directory (Global_Event_Display_Order (I)).Help)); 1564 end loop; 1565 end Show_Event; 1566 1567 -------------------- 1568 -- Show_One_Task -- 1569 -------------------- 1570 1571 procedure Show_One_Task 1572 (Task_Value : Task_Id; 1573 Full_Display : Boolean := False; 1574 Suppress_Header : Boolean := False; 1575 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) 1576 is 1577 Task_SP : System.Address := Address_Zero; 1578 Stack_Base : System.Address := Address_Zero; 1579 Stack_Top : System.Address := Address_Zero; 1580 TCB_Size : Unsigned_Longword := 0; 1581 CMA_TCB_Size : Unsigned_Longword := 0; 1582 Stack_Guard_Size : Unsigned_Longword := 0; 1583 Total_Task_Storage : Unsigned_Longword := 0; 1584 Stack_In_Use : Unsigned_Longword := 0; 1585 Reserved_Size : Unsigned_Longword := 0; 1586 Hold_Flag : Unsigned_Longword := 0; 1587 Sched_State : Unsigned_Longword := 0; 1588 User_Prio : Unsigned_Longword := 0; 1589 Stack_Size : Unsigned_Longword := 0; 1590 Run_State : Boolean := False; 1591 Rea_State : Boolean := False; 1592 Sus_State : Boolean := False; 1593 Ter_State : Boolean := False; 1594 1595 Current_Flag : AASCIC := NoStar; 1596 Hold_String : AASCIC := NoHold; 1597 Ada_State : AASCIC := Ada_State_Invalid_State; 1598 Debug_State : AASCIC := Debug_State_Emp; 1599 1600 Ada_State_Len : constant Unsigned_Longword := 17; 1601 Debug_State_Len : constant Unsigned_Longword := 5; 1602 1603 Entry_Call : Entry_Call_Record; 1604 1605 begin 1606 1607 -- Initialize local task info variables 1608 1609 Task_SP := Address_Zero; 1610 Stack_Base := Address_Zero; 1611 Stack_Top := Address_Zero; 1612 CMA_TCB_Size := 0; 1613 Stack_Guard_Size := 0; 1614 Reserved_Size := 0; 1615 Hold_Flag := 0; 1616 Sched_State := 0; 1617 TCB_Size := Unsigned_Longword (Task_Id'Size); 1618 1619 if not Suppress_Header or else Full_Display then 1620 Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); 1621 Print_Routine (Print_FAO, Print_Newline, To_UL (Header)); 1622 end if; 1623 1624 Trace_Output ("Show_One_Task Task Value: "); 1625 Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); 1626 1627 -- Callback to DEBUG to get some task info 1628 1629 if Task_Value.Common.State /= Terminated then 1630 Debug_Get 1631 (STPO.Get_Thread_Id (Task_Value), 1632 CMA_C_DEBGET_STACKPTR, 1633 Task_SP, 1634 8); 1635 1636 Debug_Get 1637 (STPO.Get_Thread_Id (Task_Value), 1638 CMA_C_DEBGET_TCB_SIZE, 1639 CMA_TCB_Size, 1640 4); 1641 1642 Debug_Get 1643 (STPO.Get_Thread_Id (Task_Value), 1644 CMA_C_DEBGET_GUARDSIZE, 1645 Stack_Guard_Size, 1646 4); 1647 1648 Debug_Get 1649 (STPO.Get_Thread_Id (Task_Value), 1650 CMA_C_DEBGET_YELLOWSIZE, 1651 Reserved_Size, 1652 4); 1653 1654 Debug_Get 1655 (STPO.Get_Thread_Id (Task_Value), 1656 CMA_C_DEBGET_STACK_BASE, 1657 Stack_Base, 1658 8); 1659 1660 Debug_Get 1661 (STPO.Get_Thread_Id (Task_Value), 1662 CMA_C_DEBGET_STACK_TOP, 1663 Stack_Top, 1664 8); 1665 1666 Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top) 1667 - Reserved_Size - Stack_Guard_Size; 1668 Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4; 1669 Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size 1670 + Reserved_Size + CMA_TCB_Size; 1671 1672 Debug_Get 1673 (STPO.Get_Thread_Id (Task_Value), 1674 CMA_C_DEBGET_IS_HELD, 1675 Hold_Flag, 1676 4); 1677 1678 Hold_String := (if Hold_Flag /= 0 then Hold else NoHold); 1679 1680 Debug_Get 1681 (STPO.Get_Thread_Id (Task_Value), 1682 CMA_C_DEBGET_SCHED_STATE, 1683 Sched_State, 1684 4); 1685 end if; 1686 1687 Run_State := False; 1688 Rea_State := False; 1689 Sus_State := Task_Value.Common.State = Unactivated; 1690 Ter_State := Task_Value.Common.State = Terminated; 1691 1692 if not Ter_State then 1693 Run_State := Sched_State = 0; 1694 Rea_State := Sched_State = 1; 1695 Sus_State := Sched_State /= 0 and Sched_State /= 1; 1696 end if; 1697 1698 -- Set the debug state 1699 1700 if Run_State then 1701 Debug_State := Debug_State_Run; 1702 elsif Rea_State then 1703 Debug_State := Debug_State_Rea; 1704 elsif Sus_State then 1705 Debug_State := Debug_State_Sus; 1706 elsif Ter_State then 1707 Debug_State := Debug_State_Ter; 1708 end if; 1709 1710 Trace_Output ("Before case State: "); 1711 Trace_Output (Task_States'Image (Task_Value.Common.State)); 1712 1713 -- Set the Ada state 1714 1715 case Task_Value.Common.State is 1716 when Unactivated => 1717 Ada_State := Ada_State_Not_Yet_Activated; 1718 1719 when Activating => 1720 Ada_State := Ada_State_Activating; 1721 1722 when Runnable => 1723 Ada_State := Ada_State_Runnable; 1724 1725 when Terminated => 1726 Ada_State := Ada_State_Terminated; 1727 1728 when Activator_Sleep => 1729 Ada_State := Ada_State_Activating_Tasks; 1730 1731 when Acceptor_Sleep => 1732 Ada_State := Ada_State_Accept; 1733 1734 when Acceptor_Delay_Sleep => 1735 Ada_State := Ada_State_Select_or_Delay; 1736 1737 when Entry_Caller_Sleep => 1738 Entry_Call := 1739 Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); 1740 1741 case Entry_Call.Mode is 1742 when Simple_Call => 1743 Ada_State := Ada_State_Entry_Call; 1744 when Conditional_Call => 1745 Ada_State := Ada_State_Cond_Entry_Call; 1746 when Timed_Call => 1747 Ada_State := Ada_State_Timed_Entry_Call; 1748 when Asynchronous_Call => 1749 Ada_State := Ada_State_Async_Entry_Call; 1750 end case; 1751 1752 when Async_Select_Sleep => 1753 Ada_State := Ada_State_Select_or_Abort; 1754 1755 when Delay_Sleep => 1756 Ada_State := Ada_State_Delay; 1757 1758 when Master_Completion_Sleep => 1759 Ada_State := Ada_State_Completed; 1760 1761 when Master_Phase_2_Sleep => 1762 Ada_State := Ada_State_Completed; 1763 1764 when Interrupt_Server_Idle_Sleep | 1765 Interrupt_Server_Blocked_Interrupt_Sleep | 1766 Timer_Server_Sleep | 1767 Interrupt_Server_Blocked_On_Event_Flag => 1768 Ada_State := Ada_State_Server; 1769 1770 when AST_Server_Sleep => 1771 Ada_State := Ada_State_IO_or_AST; 1772 1773 when Asynchronous_Hold => 1774 Ada_State := Ada_State_Async_Hold; 1775 1776 end case; 1777 1778 if Task_Value.Terminate_Alternative then 1779 Ada_State := Ada_State_Select_or_Term; 1780 end if; 1781 1782 if Task_Value.Aborting then 1783 Ada_State := Ada_State_Aborting; 1784 end if; 1785 1786 User_Prio := To_UL (Task_Value.Common.Current_Priority); 1787 Trace_Output ("After user_prio"); 1788 1789 -- Flag the current task 1790 1791 Current_Flag := (if Task_Value = Self then Star else NoStar); 1792 1793 -- Show task info 1794 1795 Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5<!UI!>")), 1796 To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1)); 1797 1798 Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio); 1799 1800 Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")), 1801 To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State), 1802 Ada_State_Len, To_UL (Ada_State)); 1803 1804-- Print_Routine (Print_Symbol, Print_Newline, 1805-- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); 1806 1807 Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); 1808 1809 -- If /full qualfier passed, show detailed info 1810 1811 if Full_Display then 1812 Show_Rendezvous (Task_Value, Ada_State, Full_Display, 1813 Suppress_Header, Print_Routine); 1814 1815 List_Entry_Waiters (Task_Value, Full_Display, 1816 Suppress_Header, Print_Routine); 1817 1818 Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); 1819 1820 declare 1821 Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len, 1822 Task_Value.Common.Task_Image 1823 (1 .. Task_Value.Common.Task_Image_Len)); 1824 begin 1825 Print_Routine (Print_FAO, Print_Newline, 1826 To_UL (DoAC (" Task type: !AC")), 1827 To_UL (Task_Image'Address)); 1828 end; 1829 1830 -- How to find Creation_PC ??? 1831-- Print_Routine (Print_FAO, No_Print, 1832-- To_UL (DoAC (" Created at PC: ")), 1833-- Print_Routine (Print_FAO, Print_Newline, Creation_PC); 1834 1835 if Task_Value.Common.Parent /= null then 1836 Print_Routine (Print_FAO, Print_Newline, 1837 To_UL (DoAC (" Parent task: %TASK !UI")), 1838 To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1)); 1839 else 1840 Print_Routine (Print_FAO, Print_Newline, 1841 To_UL (DoAC (" Parent task: none"))); 1842 end if; 1843 1844-- Print_Routine (Print_FAO, No_Print, 1845-- To_UL (DoAC (" Start PC: "))); 1846-- Print_Routine (Print_Symbol, Print_Newline, 1847-- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); 1848 1849 Print_Routine (Print_FAO, Print_Newline, 1850 To_UL (DoAC ( 1851 " Task control block: Stack storage (bytes):"))); 1852 1853 Print_Routine (Print_FAO, Print_Newline, 1854 To_UL (DoAC ( 1855 " Task value: !10<!UI!> RESERVED_BYTES: !10UI")), 1856 To_UL (Task_Value), Reserved_Size); 1857 1858 Print_Routine (Print_FAO, Print_Newline, 1859 To_UL (DoAC ( 1860 " Entries: !10<!UI!> TOP_GUARD_SIZE: !10UI")), 1861 To_UL (Task_Value.Entry_Num), Stack_Guard_Size); 1862 1863 Print_Routine (Print_FAO, Print_Newline, 1864 To_UL (DoAC ( 1865 " Size: !10<!UI!> STORAGE_SIZE: !10UI")), 1866 TCB_Size + CMA_TCB_Size, Stack_Size); 1867 1868 Print_Routine (Print_FAO, Print_Newline, 1869 To_UL (DoAC ( 1870 " Stack addresses: Bytes in use: !10UI")), 1871 Stack_In_Use); 1872 1873 Print_Routine (Print_FAO, Print_Newline, 1874 To_UL (DoAC (" Top address: !10<!XI!>")), 1875 To_UL (Stack_Top)); 1876 1877 Print_Routine (Print_FAO, Print_Newline, 1878 To_UL (DoAC ( 1879 " Base address: !10<!XI!> Total storage: !10UI")), 1880 To_UL (Stack_Base), Total_Task_Storage); 1881 end if; 1882 1883 end Show_One_Task; 1884 1885 --------------------- 1886 -- Show_Rendezvous -- 1887 --------------------- 1888 1889 procedure Show_Rendezvous 1890 (Task_Value : Task_Id; 1891 Ada_State : AASCIC := Empty_Text; 1892 Full_Display : Boolean := False; 1893 Suppress_Header : Boolean := False; 1894 Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) 1895 is 1896 pragma Unreferenced (Ada_State); 1897 pragma Unreferenced (Suppress_Header); 1898 1899 Temp_Entry : Entry_Index; 1900 Entry_Call : Entry_Call_Record; 1901 Called_Task : Task_Id; 1902 AWR : constant String := " Awaiting rendezvous at: "; 1903 -- Common prefix 1904 1905 procedure Print_Accepts; 1906 -- Display information about task rendezvous accepts 1907 1908 procedure Print_Accepts is 1909 begin 1910 if Task_Value.Open_Accepts /= null then 1911 for I in Task_Value.Open_Accepts'Range loop 1912 Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S); 1913 declare 1914 Entry_Name_Image : ASCIC := 1915 (Task_Value.Entry_Names (Temp_Entry).all'Length, 1916 Task_Value.Entry_Names (Temp_Entry).all); 1917 begin 1918 Trace_Output ("Accept at: " & Entry_Name_Image.Text); 1919 Print_Routine (Print_FAO, Print_Newline, 1920 To_UL (DoAC (" accept at: !AC")), 1921 To_UL (Entry_Name_Image'Address)); 1922 end; 1923 end loop; 1924 end if; 1925 end Print_Accepts; 1926 begin 1927 if not Full_Display then 1928 return; 1929 end if; 1930 1931 Trace_Output ("Show_Rendezvous Task Value: "); 1932 Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); 1933 1934 if Task_Value.Common.State = Acceptor_Sleep and then 1935 not Task_Value.Terminate_Alternative 1936 then 1937 if Task_Value.Open_Accepts /= null then 1938 Temp_Entry := Entry_Index (Task_Value.Open_Accepts 1939 (Task_Value.Open_Accepts'First).S); 1940 declare 1941 Entry_Name_Image : ASCIC := 1942 (Task_Value.Entry_Names (Temp_Entry).all'Length, 1943 Task_Value.Entry_Names (Temp_Entry).all); 1944 begin 1945 Trace_Output (AWR & "accept " & Entry_Name_Image.Text); 1946 Print_Routine (Print_FAO, Print_Newline, 1947 To_UL (DoAC (AWR & "accept !AC")), 1948 To_UL (Entry_Name_Image'Address)); 1949 end; 1950 1951 else 1952 Print_Routine (Print_FAO, Print_Newline, 1953 To_UL (DoAC (" entry name unavailable"))); 1954 end if; 1955 else 1956 case Task_Value.Common.State is 1957 when Acceptor_Sleep => 1958 Print_Routine (Print_FAO, Print_Newline, 1959 To_UL (DoAC (AWR & "select with terminate."))); 1960 Print_Accepts; 1961 1962 when Async_Select_Sleep => 1963 Print_Routine (Print_FAO, Print_Newline, 1964 To_UL (DoAC (AWR & "select."))); 1965 Print_Accepts; 1966 1967 when Acceptor_Delay_Sleep => 1968 Print_Routine (Print_FAO, Print_Newline, 1969 To_UL (DoAC (AWR & "select with delay."))); 1970 Print_Accepts; 1971 1972 when Entry_Caller_Sleep => 1973 Entry_Call := 1974 Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); 1975 1976 case Entry_Call.Mode is 1977 when Simple_Call => 1978 Print_Routine (Print_FAO, Print_Newline, 1979 To_UL (DoAC (AWR & "entry call"))); 1980 when Conditional_Call => 1981 Print_Routine (Print_FAO, Print_Newline, 1982 To_UL (DoAC (AWR & "entry call with else"))); 1983 when Timed_Call => 1984 Print_Routine (Print_FAO, Print_Newline, 1985 To_UL (DoAC (AWR & "entry call with delay"))); 1986 when Asynchronous_Call => 1987 Print_Routine (Print_FAO, Print_Newline, 1988 To_UL (DoAC (AWR & "entry call with abort"))); 1989 end case; 1990 Called_Task := Entry_Call.Called_Task; 1991 declare 1992 Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len, 1993 Called_Task.Common.Task_Image 1994 (1 .. Called_Task.Common.Task_Image_Len)); 1995 Entry_Name_Image : ASCIC := 1996 (Called_Task.Entry_Names (Entry_Call.E).all'Length, 1997 Called_Task.Entry_Names (Entry_Call.E).all); 1998 begin 1999 Print_Routine (Print_FAO, Print_Newline, 2000 To_UL (DoAC 2001 (" for entry !AC in %TASK !UI type !AC")), 2002 To_UL (Entry_Name_Image'Address), 2003 To_UL (Called_Task.Known_Tasks_Index), 2004 To_UL (Task_Image'Address)); 2005 end; 2006 2007 when others => 2008 return; 2009 end case; 2010 end if; 2011 2012 end Show_Rendezvous; 2013 2014 ------------------------ 2015 -- Signal_Debug_Event -- 2016 ------------------------ 2017 2018 procedure Signal_Debug_Event 2019 (Event_Kind : Event_Kind_Type; Task_Value : Task_Id) 2020 is 2021 Do_Signal : Boolean; 2022 EVCB : Ada_Event_Control_Block_Access; 2023 2024 EVCB_Sent : constant := 16#9B#; 2025 Ada_Facility : constant := 49; 2026 SS_DBGEVENT : constant := 1729; 2027 begin 2028 Do_Signal := Global_Task_Debug_Events (Event_Kind); 2029 2030 if not Do_Signal then 2031 if Task_Value /= null then 2032 Do_Signal := Do_Signal 2033 or else Task_Value.Common.Debug_Events (Event_Kind); 2034 end if; 2035 end if; 2036 2037 if Do_Signal then 2038 -- Build an a tasking event control block and signal DEBUG 2039 2040 EVCB := new Ada_Event_Control_Block_Type; 2041 EVCB.Code := Unsigned_Word (Event_Kind); 2042 EVCB.Sentinal := EVCB_Sent; 2043 EVCB.Facility := Ada_Facility; 2044 2045 if Task_Value /= null then 2046 EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1); 2047 else 2048 EVCB.Value := 0; 2049 end if; 2050 2051 EVCB.Sub_Event := 0; 2052 EVCB.P1 := 0; 2053 EVCB.Sigargs := 0; 2054 EVCB.Flags := 0; 2055 EVCB.Unused1 := 0; 2056 EVCB.Unused2 := 0; 2057 2058 Signal (SS_DBGEVENT, 1, To_UL (EVCB)); 2059 end if; 2060 end Signal_Debug_Event; 2061 2062 -------------------- 2063 -- Stop_All_Tasks -- 2064 -------------------- 2065 2066 procedure Stop_All_Tasks is 2067 begin 2068 null; -- VxWorks 2069 end Stop_All_Tasks; 2070 2071 ---------------------------- 2072 -- Stop_All_Tasks_Handler -- 2073 ---------------------------- 2074 2075 procedure Stop_All_Tasks_Handler is 2076 begin 2077 null; -- VxWorks 2078 end Stop_All_Tasks_Handler; 2079 2080 ----------------------- 2081 -- Suspend_All_Tasks -- 2082 ----------------------- 2083 2084 procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is 2085 pragma Unreferenced (Thread_Self); 2086 begin 2087 null; -- VxWorks 2088 end Suspend_All_Tasks; 2089 2090 ------------------------ 2091 -- Task_Creation_Hook -- 2092 ------------------------ 2093 2094 procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is 2095 pragma Unreferenced (Thread); 2096 begin 2097 null; -- VxWorks 2098 end Task_Creation_Hook; 2099 2100 --------------------------- 2101 -- Task_Termination_Hook -- 2102 --------------------------- 2103 2104 procedure Task_Termination_Hook is 2105 begin 2106 null; -- VxWorks 2107 end Task_Termination_Hook; 2108 2109 ----------- 2110 -- Trace -- 2111 ----------- 2112 2113 procedure Trace 2114 (Self_Id : Task_Id; 2115 Msg : String; 2116 Flag : Character; 2117 Other_Id : Task_Id := null) 2118 is 2119 begin 2120 if Trace_On (Flag) then 2121 Put (To_Integer (Self_Id)'Img & 2122 ':' & Flag & ':' & 2123 Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) & 2124 ':'); 2125 2126 if Other_Id /= null then 2127 Put (To_Integer (Other_Id)'Img & ':'); 2128 end if; 2129 2130 Put_Line (Msg); 2131 end if; 2132 end Trace; 2133 2134 ------------------ 2135 -- Trace_Output -- 2136 ------------------ 2137 2138 procedure Trace_Output (Message_String : String) is 2139 begin 2140 if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then 2141 Put_Output (Message_String); 2142 end if; 2143 end Trace_Output; 2144 2145 ----------- 2146 -- Write -- 2147 ----------- 2148 2149 procedure Write (Fd : Integer; S : String; Count : Integer) is 2150 Discard : System.CRTL.ssize_t; 2151 pragma Unreferenced (Discard); 2152 begin 2153 Discard := System.CRTL.write (Fd, S (S'First)'Address, 2154 System.CRTL.size_t (Count)); 2155 -- Is it really right to ignore write errors here ??? 2156 end Write; 2157 2158end System.Tasking.Debug; 2159