?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / s-tasdeb-vms.adb
blob1dbb5c53fc5b044e2056b1ebbfdd5e57850a793d
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-2012, 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
34 with Ada.Unchecked_Conversion;
35 with Ada.Unchecked_Deallocation;
36 with System.Aux_DEC;
37 with System.CRTL;
38 with System.Task_Primitives.Operations;
39 package 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 begin
1252
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
2158 end System.Tasking.Debug;
Mirror of the offical gcc git repository hosted at gcc.gnu.org