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