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 with System.Address_Image;
  41 with System.CRTL;
  42 with System.Task_Primitives;
  43 with System.Task_Primitives.Operations;
  44
  45 package body System.Tasking.Debug is
  46
  47    package STPO renames System.Task_Primitives.Operations;
  48
  49    type Trace_Flag_Set is array (Character) of Boolean;
  50
  51    Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
  52
  53    Stderr_Fd : constant := 2;
  54    --  File descriptor for standard error
  55
  56    -----------------------
  57    -- Local Subprograms --
  58    -----------------------
  59
  60    procedure Write (Fd : Integer; S : String; Count : Integer);
  61    --  Write Count characters of S to the file descriptor Fd
  62
  63    procedure Put (S : String);
  64    --  Display S on standard error
  65
  66    procedure Put_Line (S : String := "");
  67    --  Display S on standard error with an additional line terminator
  68
  69    function Task_Image (T : Task_Id) return String;
  70    --  Return the relevant characters from T.Common.Task_Image
  71
  72    function Task_Id_Image (T : Task_Id) return String;
  73    --  Return the address in hexadecimal form
  74
  75    ------------------------
  76    -- Continue_All_Tasks --
  77    ------------------------
  78
  79    procedure Continue_All_Tasks is
  80       C : Task_Id;
  81
  82       Dummy : Boolean;
  83       pragma Unreferenced (Dummy);
  84
  85    begin
  86       STPO.Lock_RTS;
  87
  88       C := All_Tasks_List;
  89       while C /= null loop
  90          Dummy := STPO.Continue_Task (C);
  91          C := C.Common.All_Tasks_Link;
  92       end loop;
  93
  94       STPO.Unlock_RTS;
  95    end Continue_All_Tasks;
  96
  97    --------------------
  98    -- Get_User_State --
  99    --------------------
 100
 101    function Get_User_State return Long_Integer is
 102    begin
 103       return STPO.Self.User_State;
 104    end Get_User_State;
 105
 106    ----------------
 107    -- List_Tasks --
 108    ----------------
 109
 110    procedure List_Tasks is
 111       C : Task_Id;
 112    begin
 113       C := All_Tasks_List;
 114
 115       while C /= null loop
 116          Print_Task_Info (C);
 117          C := C.Common.All_Tasks_Link;
 118       end loop;
 119    end List_Tasks;
 120
 121    ------------------------
 122    -- Print_Current_Task --
 123    ------------------------
 124
 125    procedure Print_Current_Task is
 126    begin
 127       Print_Task_Info (STPO.Self);
 128    end Print_Current_Task;
 129
 130    ---------------------
 131    -- Print_Task_Info --
 132    ---------------------
 133
 134    procedure Print_Task_Info (T : Task_Id) is
 135       Entry_Call : Entry_Call_Link;
 136       Parent     : Task_Id;
 137
 138    begin
 139       if T = null then
 140          Put_Line ("null task");
 141          return;
 142       end if;
 143
 144       Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State));
 145       Parent := T.Common.Parent;
 146
 147       if Parent = null then
 148          Put (", parent: <none>");
 149       else
 150          Put (", parent: " & Task_Image (Parent));
 151       end if;
 152
 153       Put (", prio:" & T.Common.Current_Priority'Img);
 154
 155       if not T.Callable then
 156          Put (", not callable");
 157       end if;
 158
 159       if T.Aborting then
 160          Put (", aborting");
 161       end if;
 162
 163       if T.Deferral_Level /= 0 then
 164          Put (", abort deferred");
 165       end if;
 166
 167       if T.Common.Call /= null then
 168          Entry_Call := T.Common.Call;
 169          Put (", serving:");
 170
 171          while Entry_Call /= null loop
 172             Put (Task_Id_Image (Entry_Call.Self));
 173             Entry_Call := Entry_Call.Acceptor_Prev_Call;
 174          end loop;
 175       end if;
 176
 177       if T.Open_Accepts /= null then
 178          Put (", accepting:");
 179
 180          for J in T.Open_Accepts'Range loop
 181             Put (T.Open_Accepts (J).S'Img);
 182          end loop;
 183
 184          if T.Terminate_Alternative then
 185             Put (" or terminate");
 186          end if;
 187       end if;
 188
 189       if T.User_State /= 0 then
 190          Put (", state:" & T.User_State'Img);
 191       end if;
 192
 193       Put_Line;
 194    end Print_Task_Info;
 195
 196    ---------
 197    -- Put --
 198    ---------
 199
 200    procedure Put (S : String) is
 201    begin
 202       Write (Stderr_Fd, S, S'Length);
 203    end Put;
 204
 205    --------------
 206    -- Put_Line --
 207    --------------
 208
 209    procedure Put_Line (S : String := "") is
 210    begin
 211       Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
 212    end Put_Line;
 213
 214    ----------------------
 215    -- Resume_All_Tasks --
 216    ----------------------
 217
 218    procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 219       C     : Task_Id;
 220       Dummy : Boolean;
 221       pragma Unreferenced (Dummy);
 222
 223    begin
 224       STPO.Lock_RTS;
 225       C := All_Tasks_List;
 226
 227       while C /= null loop
 228          Dummy := STPO.Resume_Task (C, Thread_Self);
 229          C := C.Common.All_Tasks_Link;
 230       end loop;
 231
 232       STPO.Unlock_RTS;
 233    end Resume_All_Tasks;
 234
 235    ---------------
 236    -- Set_Trace --
 237    ---------------
 238
 239    procedure Set_Trace (Flag  : Character; Value : Boolean := True) is
 240    begin
 241       Trace_On (Flag) := Value;
 242    end Set_Trace;
 243
 244    --------------------
 245    -- Set_User_State --
 246    --------------------
 247
 248    procedure Set_User_State (Value : Long_Integer) is
 249    begin
 250       STPO.Self.User_State := Value;
 251    end Set_User_State;
 252
 253    ------------------------
 254    -- Signal_Debug_Event --
 255    ------------------------
 256
 257    procedure Signal_Debug_Event
 258      (Event_Kind : Event_Kind_Type;
 259       Task_Value : Task_Id)
 260    is
 261    begin
 262       null;
 263    end Signal_Debug_Event;
 264
 265    --------------------
 266    -- Stop_All_Tasks --
 267    --------------------
 268
 269    procedure Stop_All_Tasks is
 270       C : Task_Id;
 271
 272       Dummy : Boolean;
 273       pragma Unreferenced (Dummy);
 274
 275    begin
 276       STPO.Lock_RTS;
 277
 278       C := All_Tasks_List;
 279       while C /= null loop
 280          Dummy := STPO.Stop_Task (C);
 281          C := C.Common.All_Tasks_Link;
 282       end loop;
 283
 284       STPO.Unlock_RTS;
 285    end Stop_All_Tasks;
 286
 287    ----------------------------
 288    -- Stop_All_Tasks_Handler --
 289    ----------------------------
 290
 291    procedure Stop_All_Tasks_Handler is
 292    begin
 293       STPO.Stop_All_Tasks;
 294    end Stop_All_Tasks_Handler;
 295
 296    -----------------------
 297    -- Suspend_All_Tasks --
 298    -----------------------
 299
 300    procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
 301       C     : Task_Id;
 302       Dummy : Boolean;
 303       pragma Unreferenced (Dummy);
 304
 305    begin
 306       STPO.Lock_RTS;
 307       C := All_Tasks_List;
 308
 309       while C /= null loop
 310          Dummy := STPO.Suspend_Task (C, Thread_Self);
 311          C := C.Common.All_Tasks_Link;
 312       end loop;
 313
 314       STPO.Unlock_RTS;
 315    end Suspend_All_Tasks;
 316
 317    ------------------------
 318    -- Task_Creation_Hook --
 319    ------------------------
 320
 321    procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is
 322       pragma Inspection_Point (Thread);
 323       --  gdb needs to access the thread parameter in order to implement
 324       --  the multitask mode under VxWorks.
 325
 326    begin
 327       null;
 328    end Task_Creation_Hook;
 329
 330    ----------------
 331    -- Task_Id_Image --
 332    ----------------
 333
 334    function Task_Id_Image (T : Task_Id) return String is
 335    begin
 336       if T = null then
 337          return "Null_Task_Id";
 338       else
 339          return Address_Image (T.all'Address);
 340       end if;
 341    end Task_Id_Image;
 342
 343    ----------------
 344    -- Task_Image --
 345    ----------------
 346
 347    function Task_Image (T : Task_Id) return String is
 348    begin
 349       --  In case T.Common.Task_Image_Len is uninitialized junk, we check that
 350       --  it is in range, to make this more robust.
 351
 352       if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
 353          return T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
 354       else
 355          return T.Common.Task_Image;
 356       end if;
 357    end Task_Image;
 358
 359    ---------------------------
 360    -- Task_Termination_Hook --
 361    ---------------------------
 362
 363    procedure Task_Termination_Hook is
 364    begin
 365       null;
 366    end Task_Termination_Hook;
 367
 368    -----------
 369    -- Trace --
 370    -----------
 371
 372    procedure Trace
 373      (Self_Id  : Task_Id;
 374       Msg      : String;
 375       Flag     : Character;
 376       Other_Id : Task_Id := null)
 377    is
 378    begin
 379       if Trace_On (Flag) then
 380          Put (Task_Id_Image (Self_Id) &
 381               ':' & Flag & ':' &
 382               Task_Image (Self_Id) &
 383               ':');
 384
 385          if Other_Id /= null then
 386             Put (Task_Id_Image (Other_Id) & ':');
 387          end if;
 388
 389          Put_Line (Msg);
 390       end if;
 391    end Trace;
 392
 393    -----------
 394    -- Write --
 395    -----------
 396
 397    procedure Write (Fd : Integer; S : String; Count : Integer) is
 398       Discard : System.CRTL.ssize_t;
 399       --  Ignore write errors here; this is just debugging output, and there's
 400       --  nothing to be done about errors anyway.
 401    begin
 402       Discard :=
 403         System.CRTL.write
 404           (Fd, S'Address, System.CRTL.size_t (Count));
 405    end Write;
 406
 407 end System.Tasking.Debug;