gcc/ada/s-tasdeb.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS              --
   4 --                                                                          --
   5 --                  S Y S T E M . T A S K I N G . D E B U G                 --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2002 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This package encapsulates all direct interfaces to task debugging services
  35 --  that are needed by gdb with gnat mode (1.13 and higher)
  36
  37 --  Note : This file *must* be compiled with debugging information
  38
  39 --  Do not add any dependency to GNARL packages since this package is used
  40 --  in both normal and restricted (ravenscar) environments.
  41
  42 with System.Task_Info,
  43      System.Task_Primitives.Operations,
  44      Unchecked_Conversion;
  45
  46 package body System.Tasking.Debug is
  47
  48    use Interfaces.C;
  49
  50    package STPO renames System.Task_Primitives.Operations;
  51
  52    type Integer_Address is mod 2 ** Standard'Address_Size;
  53
  54    function "+" is new
  55      Unchecked_Conversion (Task_ID, Integer_Address);
  56
  57    Hex_Address_Width : constant := (Standard'Address_Size / 4);
  58
  59    Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character :=
  60                   "0123456789abcdef";
  61
  62    subtype Buf_Range is Integer range 1 .. 80;
  63    type Buf_Array is array (Buf_Range) of aliased Character;
  64
  65    type Buffer is record
  66       Next  : Buf_Range := Buf_Range'First;
  67       Chars : Buf_Array := (Buf_Range => ' ');
  68    end record;
  69
  70    type Buffer_Ptr is access all Buffer;
  71
  72    type Trace_Flag_Set is array (Character) of Boolean;
  73
  74    Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
  75
  76    -----------------------
  77    -- Local Subprograms --
  78    -----------------------
  79
  80    procedure Put
  81      (T      : ST.Task_ID;
  82       Width  : Integer;
  83       Buffer : Buffer_Ptr);
  84    --  Put TCB pointer T, (coded in hexadecimal) into Buffer
  85    --  right-justified in Width characters.
  86
  87    procedure Put
  88      (N      : Integer_Address;
  89       Width  : Integer;
  90       Buffer : Buffer_Ptr);
  91    --  Put N (coded in decimal) into Buf right-justified in Width
  92    --  characters starting at Buf (Next).
  93
  94    procedure Put
  95      (S      : String;
  96       Width  : Integer;
  97       Buffer : Buffer_Ptr);
  98    --  Put string S into Buf left-justified in Width characters
  99    --  starting with space in Buf (Next), truncated as necessary.
 100
 101    procedure Put
 102      (C      : Character;
 103       Buffer : Buffer_Ptr);
 104    --  Put character C into Buf, left-justified, starting at Buf (Next)
 105
 106    procedure Space (Buffer : Buffer_Ptr);
 107    --  Increment Next, resulting in a space
 108
 109    procedure Space
 110      (N      : Integer;
 111       Buffer : Buffer_Ptr);
 112    --  Increment Next by N, resulting in N spaces
 113
 114    procedure Clear (Buffer : Buffer_Ptr);
 115    --  Clear Buf and reset Next to 1
 116
 117    procedure Write_Buf (Buffer : Buffer_Ptr);
 118    --  Write contents of Buf (1 .. Next) to standard output
 119
 120    -----------
 121    -- Clear --
 122    -----------
 123
 124    procedure Clear (Buffer : Buffer_Ptr) is
 125       Next : Buf_Range renames Buffer.Next;
 126       Buf  : Buf_Array renames Buffer.Chars;
 127
 128    begin
 129       Buf := (Buf_Range => ' ');
 130       Next := 1;
 131    end Clear;
 132
 133    -----------
 134    -- Image --
 135    -----------
 136
 137    function Image (T : ST.Task_ID) return String is
 138       Buf    : aliased Buffer;
 139       Result : String (1 .. Hex_Address_Width + 21);
 140
 141       use type System.Task_Info.Task_Image_Type;
 142
 143    begin
 144       Clear (Buf'Unchecked_Access);
 145       Put (T, Hex_Address_Width, Buf'Unchecked_Access);
 146       Put (':', Buf'Unchecked_Access);
 147       Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
 148       Space (Buf'Unchecked_Access);
 149
 150       if T.Common.Task_Image = null then
 151          Put ("", 15, Buf'Unchecked_Access);
 152       else
 153          Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
 154       end if;
 155
 156       for J in Result'Range loop
 157          Result (J) := Buf.Chars (J);
 158       end loop;
 159
 160       return Result;
 161    end Image;
 162
 163    ----------------
 164    -- List_Tasks --
 165    ----------------
 166
 167    procedure List_Tasks is
 168       C : ST.Task_ID;
 169
 170    begin
 171       Print_Task_Info_Header;
 172       C := All_Tasks_List;
 173
 174       while C /= null loop
 175          Print_Task_Info (C);
 176          C := C.Common.All_Tasks_Link;
 177       end loop;
 178    end List_Tasks;
 179
 180    -----------------------
 181    -- Print_Accept_Info --
 182    -----------------------
 183
 184    procedure Print_Accept_Info (T : ST.Task_ID) is
 185       Buf : aliased Buffer;
 186
 187    begin
 188       if T.Open_Accepts = null then
 189          return;
 190       end if;
 191
 192       Clear (Buf'Unchecked_Access);
 193       Space (10, Buf'Unchecked_Access);
 194       Put ("accepting:", 11, Buf'Unchecked_Access);
 195
 196       for J in T.Open_Accepts.all'Range loop
 197          Put (Integer_Address (T.Open_Accepts (J).S), 3, Buf'Unchecked_Access);
 198       end loop;
 199
 200       Write_Buf (Buf'Unchecked_Access);
 201    end Print_Accept_Info;
 202
 203    ------------------------
 204    -- Print_Current_Task --
 205    ------------------------
 206
 207    procedure Print_Current_Task is
 208    begin
 209       Print_Task_Info (STPO.Self);
 210    end Print_Current_Task;
 211
 212    ---------------------
 213    -- Print_Task_Info --
 214    ---------------------
 215
 216    procedure Print_Task_Info (T : ST.Task_ID) is
 217       Entry_Call : Entry_Call_Link;
 218       Buf        : aliased Buffer;
 219
 220       use type System.Task_Info.Task_Image_Type;
 221
 222    begin
 223       Clear (Buf'Unchecked_Access);
 224       Put (T, Hex_Address_Width, Buf'Unchecked_Access);
 225       Put (':', Buf'Unchecked_Access);
 226       Put (' ', Buf'Unchecked_Access);
 227       Put (':', Buf'Unchecked_Access);
 228
 229       if T = null then
 230          Put (" null task", 10, Buf'Unchecked_Access);
 231          Write_Buf (Buf'Unchecked_Access);
 232          return;
 233       end if;
 234
 235       Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
 236       Space (Buf'Unchecked_Access);
 237
 238       if T.Common.Task_Image = null then
 239          Put ("", 15, Buf'Unchecked_Access);
 240       else
 241          Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
 242       end if;
 243
 244       Space (Buf'Unchecked_Access);
 245       Put (Task_States'Image (T.Common.State), 10, Buf'Unchecked_Access);
 246       Space (Buf'Unchecked_Access);
 247
 248       if T.Callable then
 249          Put ('C', Buf'Unchecked_Access);
 250       else
 251          Space (Buf'Unchecked_Access);
 252       end if;
 253
 254       if T.Open_Accepts /= null then
 255          Put ('A', Buf'Unchecked_Access);
 256       else
 257          Space (Buf'Unchecked_Access);
 258       end if;
 259
 260       if T.Common.Call /= null then
 261          Put ('C', Buf'Unchecked_Access);
 262       else
 263          Space (Buf'Unchecked_Access);
 264       end if;
 265
 266       if T.Terminate_Alternative then
 267          Put ('T', Buf'Unchecked_Access);
 268       else
 269          Space (Buf'Unchecked_Access);
 270       end if;
 271
 272       if T.Aborting then
 273          Put ('A', Buf'Unchecked_Access);
 274       else
 275          Space (Buf'Unchecked_Access);
 276       end if;
 277
 278       if T.Deferral_Level = 0 then
 279          Space (3, Buf'Unchecked_Access);
 280       else
 281          Put ('D', Buf'Unchecked_Access);
 282          if T.Deferral_Level < 0 then
 283             Put ("<0", 2, Buf'Unchecked_Access);
 284          elsif T.Deferral_Level > 1 then
 285             Put (Integer_Address (T.Deferral_Level), 2, Buf'Unchecked_Access);
 286          else
 287             Space (2, Buf'Unchecked_Access);
 288          end if;
 289       end if;
 290
 291       Space (Buf'Unchecked_Access);
 292       Put (Integer_Address (T.Master_of_Task), 1, Buf'Unchecked_Access);
 293       Space (Buf'Unchecked_Access);
 294       Put (Integer_Address (T.Master_Within), 1, Buf'Unchecked_Access);
 295       Put (',', Buf'Unchecked_Access);
 296       Space (Buf'Unchecked_Access);
 297       Put (Integer_Address (T.Awake_Count), 1, Buf'Unchecked_Access);
 298       Space (Buf'Unchecked_Access);
 299       Put (Integer_Address (T.Alive_Count), 1, Buf'Unchecked_Access);
 300       Put (',', Buf'Unchecked_Access);
 301       Space (Buf'Unchecked_Access);
 302       Put (Integer_Address (T.ATC_Nesting_Level), 1, Buf'Unchecked_Access);
 303       Space (Buf'Unchecked_Access);
 304       Put (Integer_Address (T.Pending_ATC_Level), 1, Buf'Unchecked_Access);
 305       Put (',', Buf'Unchecked_Access);
 306       Space (Buf'Unchecked_Access);
 307       Put (Integer_Address (T.Common.Wait_Count), 1, Buf'Unchecked_Access);
 308       Put (',', Buf'Unchecked_Access);
 309       Space (Buf'Unchecked_Access);
 310       Put (Integer_Address (T.User_State), 1, Buf'Unchecked_Access);
 311       Write_Buf (Buf'Unchecked_Access);
 312
 313       if T.Common.Call /= null then
 314          Entry_Call := T.Common.Call;
 315          Clear (Buf'Unchecked_Access);
 316          Space (10, Buf'Unchecked_Access);
 317          Put ("serving:", 8, Buf'Unchecked_Access);
 318
 319          while Entry_Call /= null loop
 320             Put (Integer_Address
 321               (Entry_Call.Self.Serial_Number), 5, Buf'Unchecked_Access);
 322             Entry_Call := Entry_Call.Acceptor_Prev_Call;
 323          end loop;
 324
 325          Write_Buf (Buf'Unchecked_Access);
 326       end if;
 327
 328       Print_Accept_Info (T);
 329    end Print_Task_Info;
 330
 331    ----------------------------
 332    -- Print_Task_Info_Header --
 333    ----------------------------
 334
 335    procedure Print_Task_Info_Header is
 336       Buf : aliased Buffer;
 337
 338    begin
 339       Clear (Buf'Unchecked_Access);
 340       Put ("TASK_ID", Hex_Address_Width, Buf'Unchecked_Access);
 341       Put (':', Buf'Unchecked_Access);
 342       Put ('F', Buf'Unchecked_Access);
 343       Put (':', Buf'Unchecked_Access);
 344       Put ("SERIAL_NUMBER", 4, Buf'Unchecked_Access);
 345       Space (Buf'Unchecked_Access);
 346       Put (" NAME", 15, Buf'Unchecked_Access);
 347       Put (" STATE", 10, Buf'Unchecked_Access);
 348       Space (11, Buf'Unchecked_Access);
 349       Put ("MAST", 5, Buf'Unchecked_Access);
 350       Put ("AWAK", 5, Buf'Unchecked_Access);
 351       Put ("ATC", 5, Buf'Unchecked_Access);
 352       Put ("WT", 3, Buf'Unchecked_Access);
 353       Put ("DBG", 3, Buf'Unchecked_Access);
 354       Write_Buf (Buf'Unchecked_Access);
 355    end Print_Task_Info_Header;
 356
 357    ---------
 358    -- Put --
 359    ---------
 360
 361    procedure Put
 362      (T      : ST.Task_ID;
 363       Width  : Integer;
 364       Buffer : Buffer_Ptr)
 365    is
 366       J     : Integer;
 367       X     : Integer_Address := +T;
 368       Next  : Buf_Range renames Buffer.Next;
 369       Buf   : Buf_Array renames Buffer.Chars;
 370       First : constant Integer := Next;
 371       Wdth  : Integer := Width;
 372
 373    begin
 374       if Wdth > Buf'Last - Next then
 375          Wdth := Buf'Last - Next;
 376       end if;
 377
 378       J := Next + (Wdth - 1);
 379
 380       if X = 0 then
 381          Buf (J) := '0';
 382
 383       else
 384          while X > 0 loop
 385             Buf (J) := Hex_Digits (X rem 16);
 386             J := J - 1;
 387             X := X / 16;
 388
 389             --  Check for overflow
 390
 391             if J < First and then X > 0 then
 392                Buf (J + 1) := '*';
 393                exit;
 394             end if;
 395
 396          end loop;
 397       end if;
 398
 399       Next := Next + Wdth;
 400    end Put;
 401
 402    procedure Put
 403      (N      : Integer_Address;
 404       Width  : Integer;
 405       Buffer : Buffer_Ptr)
 406    is
 407       J     : Integer;
 408       X     : Integer_Address := N;
 409       Next  : Buf_Range renames Buffer.Next;
 410       Buf   : Buf_Array renames Buffer.Chars;
 411       First : constant Integer := Next;
 412       Wdth  : Integer := Width;
 413
 414    begin
 415       if Wdth > Buf'Last - Next then
 416          Wdth := Buf'Last - Next;
 417       end if;
 418
 419       J := Next + (Wdth - 1);
 420
 421       if N = 0 then
 422          Buf (J) := '0';
 423
 424       else
 425          while X > 0 loop
 426             Buf (J) := Hex_Digits (X rem 10);
 427             J := J - 1;
 428             X := X / 10;
 429
 430             --  Check for overflow
 431
 432             if J < First and then X > 0 then
 433                Buf (J + 1) := '*';
 434                exit;
 435             end if;
 436          end loop;
 437       end if;
 438
 439       Next := Next + Wdth;
 440    end Put;
 441
 442    procedure Put
 443      (S      : String;
 444       Width  : Integer;
 445       Buffer : Buffer_Ptr)
 446    is
 447       Next  : Buf_Range renames Buffer.Next;
 448       Buf   : Buf_Array renames Buffer.Chars;
 449       Bound : constant Integer := Integer'Min (Next + Width, Buf'Last);
 450       J     : Integer := Next;
 451
 452    begin
 453       for K in S'Range loop
 454
 455          --  Check overflow
 456
 457          if J >= Bound then
 458             Buf (J - 1) := '*';
 459             exit;
 460          end if;
 461
 462          Buf (J) := S (K);
 463          J := J + 1;
 464       end loop;
 465
 466       Next := Bound;
 467    end Put;
 468
 469    procedure Put
 470      (C      : Character;
 471       Buffer : Buffer_Ptr)
 472    is
 473       Next : Buf_Range renames Buffer.Next;
 474       Buf  : Buf_Array renames Buffer.Chars;
 475
 476    begin
 477       if Next >= Buf'Last then
 478          Buf (Next) := '*';
 479       else Buf (Next) := C;
 480          Next := Next + 1;
 481       end if;
 482    end Put;
 483
 484    ----------------------
 485    -- Resume_All_Tasks --
 486    ----------------------
 487
 488    procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 489       C : ST.Task_ID;
 490       R : Boolean;
 491
 492    begin
 493       STPO.Lock_RTS;
 494       C := All_Tasks_List;
 495
 496       while C /= null loop
 497          R := STPO.Resume_Task (C, Thread_Self);
 498          C := C.Common.All_Tasks_Link;
 499       end loop;
 500
 501       STPO.Unlock_RTS;
 502    end Resume_All_Tasks;
 503
 504    ----------
 505    -- Self --
 506    ----------
 507
 508    function Self return Task_ID is
 509    begin
 510       return STPO.Self;
 511    end Self;
 512
 513    ---------------
 514    -- Set_Trace --
 515    ---------------
 516
 517    procedure Set_Trace
 518      (Flag  : Character;
 519       Value : Boolean := True)
 520    is
 521    begin
 522       Trace_On (Flag) := Value;
 523    end Set_Trace;
 524
 525    --------------------
 526    -- Set_User_State --
 527    --------------------
 528
 529    procedure Set_User_State (Value : Integer) is
 530    begin
 531       STPO.Self.User_State := Value;
 532    end Set_User_State;
 533
 534    -----------
 535    -- Space --
 536    -----------
 537
 538    procedure Space (Buffer : Buffer_Ptr) is
 539       Next : Buf_Range renames Buffer.Next;
 540       Buf  : Buf_Array renames Buffer.Chars;
 541
 542    begin
 543       if Next >= Buf'Last then
 544          Buf (Next) := '*';
 545       else
 546          Next := Next + 1;
 547       end if;
 548    end Space;
 549
 550    procedure Space
 551      (N      : Integer;
 552       Buffer : Buffer_Ptr)
 553    is
 554       Next : Buf_Range renames Buffer.Next;
 555       Buf  : Buf_Array renames Buffer.Chars;
 556
 557    begin
 558       if Next + N > Buf'Last then
 559          Buf (Next) := '*';
 560       else
 561          Next := Next + N;
 562       end if;
 563    end Space;
 564
 565    -----------------------
 566    -- Suspend_All_Tasks --
 567    -----------------------
 568
 569    procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 570       C : ST.Task_ID;
 571       R : Boolean;
 572
 573    begin
 574       STPO.Lock_RTS;
 575       C := All_Tasks_List;
 576
 577       while C /= null loop
 578          R := STPO.Suspend_Task (C, Thread_Self);
 579          C := C.Common.All_Tasks_Link;
 580       end loop;
 581
 582       STPO.Unlock_RTS;
 583    end Suspend_All_Tasks;
 584
 585    ------------------------
 586    -- Task_Creation_Hook --
 587    ------------------------
 588
 589    procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
 590       pragma Inspection_Point (Thread);
 591       --  gdb needs to access the thread parameter in order to implement
 592       --  the multitask mode under VxWorks.
 593
 594    begin
 595       null;
 596    end Task_Creation_Hook;
 597
 598    ---------------------------
 599    -- Task_Termination_Hook --
 600    ---------------------------
 601
 602    procedure Task_Termination_Hook is
 603    begin
 604       null;
 605    end Task_Termination_Hook;
 606
 607    -----------
 608    -- Trace --
 609    -----------
 610
 611    procedure Trace
 612      (Self_ID  : ST.Task_ID;
 613       Msg      : String;
 614       Other_ID : ST.Task_ID;
 615       Flag     : Character)
 616    is
 617       Buf : aliased Buffer;
 618       use type System.Task_Info.Task_Image_Type;
 619
 620    begin
 621       if Trace_On (Flag) then
 622          Clear (Buf'Unchecked_Access);
 623          Put (Self_ID, Hex_Address_Width, Buf'Unchecked_Access);
 624          Put (':', Buf'Unchecked_Access);
 625          Put (Flag, Buf'Unchecked_Access);
 626          Put (':', Buf'Unchecked_Access);
 627          Put
 628            (Integer_Address (Self_ID.Serial_Number),
 629             4, Buf'Unchecked_Access);
 630          Space (Buf'Unchecked_Access);
 631
 632          if Self_ID.Common.Task_Image = null then
 633             Put ("", 15, Buf'Unchecked_Access);
 634          else
 635             Put (Self_ID.Common.Task_Image.all, 15, Buf'Unchecked_Access);
 636          end if;
 637
 638          Space (Buf'Unchecked_Access);
 639
 640          if Other_ID /= null then
 641             Put
 642               (Integer_Address (Other_ID.Serial_Number),
 643                4, Buf'Unchecked_Access);
 644             Space (Buf'Unchecked_Access);
 645          end if;
 646
 647          Put (Msg, Buf.Chars'Last - Buf.Next + 1, Buf'Unchecked_Access);
 648          Write_Buf (Buf'Unchecked_Access);
 649       end if;
 650    end Trace;
 651
 652    procedure Trace
 653      (Self_ID : ST.Task_ID;
 654       Msg     : String;
 655       Flag    : Character)
 656    is
 657    begin
 658       Trace (Self_ID, Msg, null, Flag);
 659    end Trace;
 660
 661    procedure Trace
 662      (Msg : String;
 663       Flag : Character)
 664    is
 665       Self_ID : constant ST.Task_ID := STPO.Self;
 666
 667    begin
 668       Trace (Self_ID, Msg, null, Flag);
 669    end Trace;
 670
 671    procedure Trace
 672      (Msg      : String;
 673       Other_ID : ST.Task_ID;
 674       Flag     : Character)
 675    is
 676       pragma Warnings (Off, Other_ID);
 677
 678       Self_ID : constant ST.Task_ID := STPO.Self;
 679
 680    begin
 681       Trace (Self_ID, Msg, null, Flag);
 682    end Trace;
 683
 684    ---------------
 685    -- Write_Buf --
 686    ---------------
 687
 688    procedure Write_Buf (Buffer : Buffer_Ptr) is
 689       Next : Buf_Range renames Buffer.Next;
 690       Buf  : Buf_Array renames Buffer.Chars;
 691
 692       procedure put_char (C : Integer);
 693       pragma Import (C, put_char, "put_char");
 694
 695    begin
 696       for J in 1 .. Next - 1 loop
 697          put_char (Character'Pos (Buf (J)));
 698       end loop;
 699
 700       put_char (Character'Pos (ASCII.LF));
 701    end Write_Buf;
 702
 703 end System.Tasking.Debug;