gcc/ada/s-tasdeb.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                --
   4 --                                                                          --
   5 --                  S Y S T E M . T A S K I N G . D E B U G                 --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2014, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This package encapsulates all direct interfaces to task debugging services
  33 --  that are needed by gdb with gnat mode.
  34
  35 --  Note : This file *must* be compiled with debugging information
  36
  37 --  Do not add any dependency to GNARL packages since this package is used
  38 --  in both normal and restricted (ravenscar) environments.
  39
  40 pragma Restriction_Warnings (No_Secondary_Stack);
  41 --  We wish to avoid secondary stack usage here, because (e.g.) Trace is called
  42 --  at delicate times, such as during task termination after the secondary
  43 --  stack has been deallocated. It's just a warning, so we don't require
  44 --  partition-wide consistency.
  45
  46 with System.CRTL;
  47 with System.Storage_Elements; use System.Storage_Elements;
  48 with System.Task_Primitives;
  49 with System.Task_Primitives.Operations;
  50
  51 package body System.Tasking.Debug is
  52
  53    package STPO renames System.Task_Primitives.Operations;
  54
  55    type Trace_Flag_Set is array (Character) of Boolean;
  56
  57    Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
  58
  59    Stderr_Fd : constant := 2;
  60    --  File descriptor for standard error
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    procedure Write (Fd : Integer; S : String; Count : Integer);
  67    --  Write Count characters of S to the file descriptor Fd
  68
  69    procedure Put (S : String);
  70    --  Display S on standard error
  71
  72    procedure Put_Line (S : String := "");
  73    --  Display S on standard error with an additional line terminator
  74
  75    procedure Put_Task_Image (T : Task_Id);
  76    --  Display relevant characters from T.Common.Task_Image on standard error
  77
  78    procedure Put_Task_Id_Image (T : Task_Id);
  79    --  Display address in hexadecimal form on standard error
  80
  81    ------------------------
  82    -- Continue_All_Tasks --
  83    ------------------------
  84
  85    procedure Continue_All_Tasks is
  86       C     : Task_Id;
  87       Dummy : Boolean;
  88
  89    begin
  90       STPO.Lock_RTS;
  91
  92       C := All_Tasks_List;
  93       while C /= null loop
  94          Dummy := STPO.Continue_Task (C);
  95          C := C.Common.All_Tasks_Link;
  96       end loop;
  97
  98       STPO.Unlock_RTS;
  99    end Continue_All_Tasks;
 100
 101    --------------------
 102    -- Get_User_State --
 103    --------------------
 104
 105    function Get_User_State return Long_Integer is
 106    begin
 107       return STPO.Self.User_State;
 108    end Get_User_State;
 109
 110    ----------------
 111    -- List_Tasks --
 112    ----------------
 113
 114    procedure List_Tasks is
 115       C : Task_Id;
 116    begin
 117       C := All_Tasks_List;
 118       while C /= null loop
 119          Print_Task_Info (C);
 120          C := C.Common.All_Tasks_Link;
 121       end loop;
 122    end List_Tasks;
 123
 124    ------------------------
 125    -- Print_Current_Task --
 126    ------------------------
 127
 128    procedure Print_Current_Task is
 129    begin
 130       Print_Task_Info (STPO.Self);
 131    end Print_Current_Task;
 132
 133    ---------------------
 134    -- Print_Task_Info --
 135    ---------------------
 136
 137    procedure Print_Task_Info (T : Task_Id) is
 138       Entry_Call : Entry_Call_Link;
 139       Parent     : Task_Id;
 140
 141    begin
 142       if T = null then
 143          Put_Line ("null task");
 144          return;
 145       end if;
 146
 147       Put_Task_Image (T);
 148       Put (": " & Task_States'Image (T.Common.State));
 149       Parent := T.Common.Parent;
 150
 151       if Parent = null then
 152          Put (", parent: <none>");
 153       else
 154          Put (", parent: ");
 155          Put_Task_Image (Parent);
 156       end if;
 157
 158       Put (", prio:" & T.Common.Current_Priority'Img);
 159
 160       if not T.Callable then
 161          Put (", not callable");
 162       end if;
 163
 164       if T.Aborting then
 165          Put (", aborting");
 166       end if;
 167
 168       if T.Deferral_Level /= 0 then
 169          Put (", abort deferred");
 170       end if;
 171
 172       if T.Common.Call /= null then
 173          Entry_Call := T.Common.Call;
 174          Put (", serving:");
 175
 176          while Entry_Call /= null loop
 177             Put_Task_Id_Image (Entry_Call.Self);
 178             Entry_Call := Entry_Call.Acceptor_Prev_Call;
 179          end loop;
 180       end if;
 181
 182       if T.Open_Accepts /= null then
 183          Put (", accepting:");
 184
 185          for J in T.Open_Accepts'Range loop
 186             Put (T.Open_Accepts (J).S'Img);
 187          end loop;
 188
 189          if T.Terminate_Alternative then
 190             Put (" or terminate");
 191          end if;
 192       end if;
 193
 194       if T.User_State /= 0 then
 195          Put (", state:" & T.User_State'Img);
 196       end if;
 197
 198       Put_Line;
 199    end Print_Task_Info;
 200
 201    ---------
 202    -- Put --
 203    ---------
 204
 205    procedure Put (S : String) is
 206    begin
 207       Write (Stderr_Fd, S, S'Length);
 208    end Put;
 209
 210    --------------
 211    -- Put_Line --
 212    --------------
 213
 214    procedure Put_Line (S : String := "") is
 215    begin
 216       Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
 217    end Put_Line;
 218
 219    -----------------------
 220    -- Put_Task_Id_Image --
 221    -----------------------
 222
 223    procedure Put_Task_Id_Image (T : Task_Id) is
 224       Address_Image_Length : constant :=
 225         13 + (if Standard'Address_Size = 64 then 10 else 0);
 226       --  Length of string to be printed for address of task
 227
 228       H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
 229       --  Table of hex digits
 230
 231       S : String (1 .. Address_Image_Length);
 232       P : Natural;
 233       N : Integer_Address;
 234       U : Natural := 0;
 235
 236    begin
 237       if T = null then
 238          Put ("Null_Task_Id");
 239
 240       else
 241          S (S'Last) := '#';
 242          P := Address_Image_Length - 1;
 243          N := To_Integer (T.all'Address);
 244          while P > 3 loop
 245             if U = 4 then
 246                S (P) := '_';
 247                P := P - 1;
 248                U := 1;
 249             else
 250                U := U + 1;
 251             end if;
 252
 253             S (P) := H (Integer (N mod 16));
 254             P := P - 1;
 255             N := N / 16;
 256          end loop;
 257
 258          S (1 .. 3) := "16#";
 259          Put (S);
 260       end if;
 261    end Put_Task_Id_Image;
 262
 263    --------------------
 264    -- Put_Task_Image --
 265    --------------------
 266
 267    procedure Put_Task_Image (T : Task_Id) is
 268    begin
 269       --  In case T.Common.Task_Image_Len is uninitialized junk, we check that
 270       --  it is in range, to make this more robust.
 271
 272       if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
 273          Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
 274       else
 275          Put (T.Common.Task_Image);
 276       end if;
 277    end Put_Task_Image;
 278
 279    ----------------------
 280    -- Resume_All_Tasks --
 281    ----------------------
 282
 283    procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 284       C     : Task_Id;
 285       Dummy : Boolean;
 286
 287    begin
 288       STPO.Lock_RTS;
 289
 290       C := All_Tasks_List;
 291       while C /= null loop
 292          Dummy := STPO.Resume_Task (C, Thread_Self);
 293          C := C.Common.All_Tasks_Link;
 294       end loop;
 295
 296       STPO.Unlock_RTS;
 297    end Resume_All_Tasks;
 298
 299    ---------------
 300    -- Set_Trace --
 301    ---------------
 302
 303    procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
 304    begin
 305       Trace_On (Flag) := Value;
 306    end Set_Trace;
 307
 308    --------------------
 309    -- Set_User_State --
 310    --------------------
 311
 312    procedure Set_User_State (Value : Long_Integer) is
 313    begin
 314       STPO.Self.User_State := Value;
 315    end Set_User_State;
 316
 317    ------------------------
 318    -- Signal_Debug_Event --
 319    ------------------------
 320
 321    procedure Signal_Debug_Event
 322      (Event_Kind : Event_Kind_Type;
 323       Task_Value : Task_Id)
 324    is
 325    begin
 326       null;
 327    end Signal_Debug_Event;
 328
 329    --------------------
 330    -- Stop_All_Tasks --
 331    --------------------
 332
 333    procedure Stop_All_Tasks is
 334       C     : Task_Id;
 335       Dummy : Boolean;
 336
 337    begin
 338       STPO.Lock_RTS;
 339
 340       C := All_Tasks_List;
 341       while C /= null loop
 342          Dummy := STPO.Stop_Task (C);
 343          C := C.Common.All_Tasks_Link;
 344       end loop;
 345
 346       STPO.Unlock_RTS;
 347    end Stop_All_Tasks;
 348
 349    ----------------------------
 350    -- Stop_All_Tasks_Handler --
 351    ----------------------------
 352
 353    procedure Stop_All_Tasks_Handler is
 354    begin
 355       STPO.Stop_All_Tasks;
 356    end Stop_All_Tasks_Handler;
 357
 358    -----------------------
 359    -- Suspend_All_Tasks --
 360    -----------------------
 361
 362    procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 363       C     : Task_Id;
 364       Dummy : Boolean;
 365
 366    begin
 367       STPO.Lock_RTS;
 368
 369       C := All_Tasks_List;
 370       while C /= null loop
 371          Dummy := STPO.Suspend_Task (C, Thread_Self);
 372          C := C.Common.All_Tasks_Link;
 373       end loop;
 374
 375       STPO.Unlock_RTS;
 376    end Suspend_All_Tasks;
 377
 378    ------------------------
 379    -- Task_Creation_Hook --
 380    ------------------------
 381
 382    procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
 383       pragma Inspection_Point (Thread);
 384       --  gdb needs to access the thread parameter in order to implement
 385       --  the multitask mode under VxWorks.
 386
 387    begin
 388       null;
 389    end Task_Creation_Hook;
 390
 391    ---------------------------
 392    -- Task_Termination_Hook --
 393    ---------------------------
 394
 395    procedure Task_Termination_Hook is
 396    begin
 397       null;
 398    end Task_Termination_Hook;
 399
 400    -----------
 401    -- Trace --
 402    -----------
 403
 404    procedure Trace
 405      (Self_Id  : Task_Id;
 406       Msg      : String;
 407       Flag     : Character;
 408       Other_Id : Task_Id := null)
 409    is
 410    begin
 411       if Trace_On (Flag) then
 412          Put_Task_Id_Image (Self_Id);
 413          Put (":" & Flag & ":");
 414          Put_Task_Image (Self_Id);
 415          Put (":");
 416
 417          if Other_Id /= null then
 418             Put_Task_Id_Image (Other_Id);
 419             Put (":");
 420          end if;
 421
 422          Put_Line (Msg);
 423       end if;
 424    end Trace;
 425
 426    -----------
 427    -- Write --
 428    -----------
 429
 430    procedure Write (Fd : Integer; S : String; Count : Integer) is
 431       Discard : System.CRTL.ssize_t;
 432       --  Ignore write errors here; this is just debugging output, and there's
 433       --  nothing to be done about errors anyway.
 434    begin
 435       Discard :=
 436         System.CRTL.write
 437           (Fd, S'Address, System.CRTL.size_t (Count));
 438    end Write;
 439
 440    -----------------
 441    -- Master_Hook --
 442    -----------------
 443
 444    procedure Master_Hook
 445      (Dependent    : Task_Id;
 446       Parent       : Task_Id;
 447       Master_Level : Integer)
 448    is
 449       pragma Inspection_Point (Dependent);
 450       pragma Inspection_Point (Parent);
 451       pragma Inspection_Point (Master_Level);
 452    begin
 453       null;
 454    end Master_Hook;
 455
 456    ---------------------------
 457    -- Master_Completed_Hook --
 458    ---------------------------
 459
 460    procedure Master_Completed_Hook
 461      (Self_ID      : Task_Id;
 462       Master_Level : Integer)
 463    is
 464       pragma Inspection_Point (Self_ID);
 465       pragma Inspection_Point (Master_Level);
 466    begin
 467       null;
 468    end Master_Completed_Hook;
 469
 470 end System.Tasking.Debug;