gcc/ada/s-tratas-default.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                 S Y S T E M . T R A C E S . T A S K I N G                --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --           Copyright (C) 2001-2004 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Tasking;       use System.Tasking;
  35 with System.Soft_Links;
  36 with System.Parameters;
  37 with System.Traces.Format; use System.Traces.Format;
  38 with System.Traces;        use System.Traces;
  39
  40 package body System.Traces.Tasking is
  41
  42    use System.Tasking;
  43    use System.Traces;
  44    use System.Traces.Format;
  45
  46    package SSL renames System.Soft_Links;
  47
  48    function Extract_Accepts (Task_Name : Task_Id) return String_Trace;
  49    --  This function is used to extract data joined with
  50    --  W_Select, WT_Select, W_Accept events
  51
  52    ---------------------
  53    -- Send_Trace_Info --
  54    ---------------------
  55
  56    procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is
  57       Task_S  : constant String := SSL.Task_Name.all;
  58       Task2_S : constant String :=
  59                   Task_Name2.Common.Task_Image
  60                     (1 .. Task_Name2.Common.Task_Image_Len);
  61       Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
  62
  63       L0 : Integer := Task_S'Length;
  64       L1 : Integer := Task2_S'Length;
  65
  66    begin
  67       if Parameters.Runtime_Traces then
  68          case Id is
  69             when M_RDV_Complete | PO_Done =>
  70                Trace_S (1 .. 3)                 := "/N:";
  71                Trace_S (4 .. 3 + L0)            := Task_S;
  72                Trace_S (4 + L0 .. 6 + L0)       := "/C:";
  73                Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
  74                Send_Trace (Id, Trace_S);
  75
  76             when E_Missed =>
  77                Trace_S (1 .. 3)                 := "/N:";
  78                Trace_S (4 .. 3 + L0)            := Task_S;
  79                Trace_S (4 + L0 .. 6 + L0)       := "/A:";
  80                Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
  81                Send_Trace (Id, Trace_S);
  82
  83             when E_Kill =>
  84                Trace_S (1 .. 3)                 := "/N:";
  85                Trace_S (4 .. 3 + L1)            := Task2_S;
  86                Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
  87                Send_Trace (Id, Trace_S);
  88
  89             when T_Create =>
  90                Trace_S (1 .. 3)                 := "/N:";
  91                Trace_S (4 .. 3 + L1)            := Task2_S;
  92                Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
  93                Send_Trace (Id, Trace_S);
  94
  95             when others =>
  96                null;
  97                --  should raise an exception ???
  98          end case;
  99       end if;
 100    end Send_Trace_Info;
 101
 102    procedure Send_Trace_Info
 103      (Id           : Trace_T;
 104       Task_Name2   : Task_Id;
 105       Entry_Number : Entry_Index)
 106    is
 107       Task_S  : constant String := SSL.Task_Name.all;
 108       Task2_S : constant String :=
 109                   Task_Name2.Common.Task_Image
 110                     (1 .. Task_Name2.Common.Task_Image_Len);
 111       Entry_S   : String := Integer'Image (Integer (Entry_Number));
 112       Trace_S   : String (1 .. 9 + Task_S'Length
 113                                  + Task2_S'Length + Entry_S'Length);
 114
 115       L0 : Integer := Task_S'Length;
 116       L1 : Integer := Task_S'Length + Entry_S'Length;
 117       L2 : Integer := Task_S'Length + Task2_S'Length;
 118
 119    begin
 120       if Parameters.Runtime_Traces then
 121          case Id is
 122             when M_Accept_Complete =>
 123                Trace_S (1 .. 3)                  := "/N:";
 124                Trace_S (4 .. 3 + L0)             := Task_S;
 125                Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 126                Trace_S (7 + L0 .. 6 + L1)         := Entry_S;
 127                Trace_S (7 + L1 .. 9 + L1)        := "/C:";
 128                Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
 129                Send_Trace (Id, Trace_S);
 130
 131             when W_Call =>
 132                Trace_S (1 .. 3)                  := "/N:";
 133                Trace_S (4 .. 3 + L0)             := Task_S;
 134                Trace_S (4 + L0 .. 6 + L0)        := "/A:";
 135                Trace_S (7 + L0 .. 6 + L2)        := Task2_S;
 136                Trace_S (7 + L2 .. 9 + L2)        := "/C:";
 137                Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
 138                Send_Trace (Id, Trace_S);
 139
 140             when others =>
 141                null;
 142                --  should raise an exception ???
 143          end case;
 144       end if;
 145    end Send_Trace_Info;
 146
 147    procedure Send_Trace_Info
 148      (Id           : Trace_T;
 149       Task_Name    : Task_Id;
 150       Task_Name2   : Task_Id;
 151       Entry_Number : Entry_Index)
 152    is
 153       Task_S  : constant String :=
 154                   Task_Name.Common.Task_Image
 155                     (1 .. Task_Name.Common.Task_Image_Len);
 156       Task2_S : constant String :=
 157                   Task_Name2.Common.Task_Image
 158                     (1 .. Task_Name2.Common.Task_Image_Len);
 159       Entry_S   : String := Integer'Image (Integer (Entry_Number));
 160       Trace_S   : String (1 .. 9 + Task_S'Length
 161                                  + Task2_S'Length + Entry_S'Length);
 162
 163       L0 : Integer := Task_S'Length;
 164       L1 : Integer := Task_S'Length + Entry_S'Length;
 165
 166    begin
 167       if Parameters.Runtime_Traces then
 168          case Id is
 169             when PO_Run =>
 170                Trace_S (1 .. 3)                  := "/N:";
 171                Trace_S (4 .. 3 + L0)             := Task_S;
 172                Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 173                Trace_S (7 + L0 .. 6 + L1)        := Entry_S;
 174                Trace_S (7 + L1 .. 9 + L1)        := "/C:";
 175                Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
 176                Send_Trace (Id, Trace_S);
 177
 178             when others =>
 179                null;
 180                --  should raise an exception ???
 181          end case;
 182       end if;
 183    end Send_Trace_Info;
 184
 185    procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
 186       Task_S  : String := SSL.Task_Name.all;
 187       Entry_S : String := Integer'Image (Integer (Entry_Number));
 188       Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
 189
 190       L0 : Integer := Task_S'Length;
 191
 192    begin
 193       if Parameters.Runtime_Traces then
 194          Trace_S (1 .. 3)                 := "/N:";
 195          Trace_S (4 .. 3 + L0)            := Task_S;
 196          Trace_S (4 + L0 .. 6 + L0)       := "/E:";
 197          Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
 198          Send_Trace (Id, Trace_S);
 199       end if;
 200    end Send_Trace_Info;
 201
 202    procedure Send_Trace_Info
 203      (Id         : Trace_T;
 204       Task_Name  : Task_Id;
 205       Task_Name2 : Task_Id)
 206    is
 207       Task_S  : constant String :=
 208                   Task_Name.Common.Task_Image
 209                     (1 .. Task_Name.Common.Task_Image_Len);
 210       Task2_S : constant String :=
 211                   Task_Name2.Common.Task_Image
 212                     (1 .. Task_Name2.Common.Task_Image_Len);
 213       Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
 214
 215       L0 : Integer := Task2_S'Length;
 216
 217    begin
 218       if Parameters.Runtime_Traces then
 219          Trace_S (1 .. 3)                 := "/N:";
 220          Trace_S (4 .. 3 + L0)            := Task2_S;
 221          Trace_S (4 + L0 .. 6 + L0)       := "/P:";
 222          Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
 223          Send_Trace (Id, Trace_S);
 224       end if;
 225    end Send_Trace_Info;
 226
 227    procedure Send_Trace_Info
 228      (Id           : Trace_T;
 229       Acceptor     : Task_Id;
 230       Entry_Number : Entry_Index;
 231       Timeout      : Duration)
 232    is
 233       Task_S     : constant String := SSL.Task_Name.all;
 234       Acceptor_S : constant String :=
 235                      Acceptor.Common.Task_Image
 236                        (1 .. Acceptor.Common.Task_Image_Len);
 237       Entry_S    : String := Integer'Image (Integer (Entry_Number));
 238       Timeout_S  : String := Duration'Image (Timeout);
 239       Trace_S    : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
 240                                    + Entry_S'Length + Timeout_S'Length);
 241
 242       L0 : Integer := Task_S'Length;
 243       L1 : Integer := Task_S'Length + Acceptor_S'Length;
 244       L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length;
 245
 246    begin
 247       if Parameters.Runtime_Traces then
 248          Trace_S (1 .. 3)                  := "/N:";
 249          Trace_S (4 .. 3 + L0)             := Task_S;
 250          Trace_S (4 + L0 .. 6 + L0)        := "/A:";
 251          Trace_S (7 + L0 .. 6 + L1)        := Acceptor_S;
 252          Trace_S (7 + L1 .. 9 + L1)        := "/E:";
 253          Trace_S (10 + L1 .. 9 + L2)       := Entry_S;
 254          Trace_S (10 + L2 .. 12 + L2)      := "/T:";
 255          Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
 256          Send_Trace (Id, Trace_S);
 257       end if;
 258    end Send_Trace_Info;
 259
 260    procedure Send_Trace_Info
 261      (Id           : Trace_T;
 262       Entry_Number : Entry_Index;
 263       Timeout      : Duration)
 264    is
 265       Task_S    : String := SSL.Task_Name.all;
 266       Entry_S   : String := Integer'Image (Integer (Entry_Number));
 267       Timeout_S : String := Duration'Image (Timeout);
 268       Trace_S   : String (1 .. 9 + Task_S'Length
 269                                  + Entry_S'Length + Timeout_S'Length);
 270
 271       L0 : Integer := Task_S'Length;
 272       L1 : Integer := Task_S'Length + Entry_S'Length;
 273
 274    begin
 275       if Parameters.Runtime_Traces then
 276          Trace_S (1 .. 3)                  := "/N:";
 277          Trace_S (4 .. 3 + L0)             := Task_S;
 278          Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 279          Trace_S (7 + L0 .. 6 + L1)        := Entry_S;
 280          Trace_S (7 + L1 .. 9 + L1)        := "/T:";
 281          Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
 282          Send_Trace (Id, Trace_S);
 283       end if;
 284    end Send_Trace_Info;
 285
 286    procedure Send_Trace_Info
 287      (Id        : Trace_T;
 288       Task_Name : Task_Id;
 289       Number    : Integer)
 290    is
 291       Task_S    : String := SSL.Task_Name.all;
 292       Number_S  : String := Integer'Image (Number);
 293       Accepts_S : String := Extract_Accepts (Task_Name);
 294       Trace_S   : String (1 .. 9 + Task_S'Length
 295                                  + Number_S'Length + Accepts_S'Length);
 296
 297       L0 : Integer := Task_S'Length;
 298       L1 : Integer := Task_S'Length + Number_S'Length;
 299
 300    begin
 301       if Parameters.Runtime_Traces then
 302          Trace_S (1 .. 3)                  := "/N:";
 303          Trace_S (4 .. 3 + L0)             := Task_S;
 304          Trace_S (4 + L0 .. 6 + L0)        := "/#:";
 305          Trace_S (7 + L0 .. 6 + L1)        := Number_S;
 306          Trace_S (7 + L1 .. 9 + L1)        := "/E:";
 307          Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
 308          Send_Trace (Id, Trace_S);
 309       end if;
 310    end Send_Trace_Info;
 311
 312    procedure Send_Trace_Info
 313      (Id        : Trace_T;
 314       Task_Name : Task_Id;
 315       Number    : Integer;
 316       Timeout   : Duration)
 317    is
 318       Task_S    : String := SSL.Task_Name.all;
 319       Timeout_S : String := Duration'Image (Timeout);
 320       Number_S  : String := Integer'Image (Number);
 321       Accepts_S : String := Extract_Accepts (Task_Name);
 322       Trace_S   : String (1 .. 12 + Task_S'Length + Timeout_S'Length
 323                                   + Number_S'Length + Accepts_S'Length);
 324
 325       L0 : Integer := Task_S'Length;
 326       L1 : Integer := Task_S'Length + Timeout_S'Length;
 327       L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length;
 328
 329    begin
 330       if Parameters.Runtime_Traces then
 331          Trace_S (1 .. 3)                  := "/N:";
 332          Trace_S (4 .. 3 + L0)             := Task_S;
 333          Trace_S (4 + L0 .. 6 + L0)        := "/T:";
 334          Trace_S (7 + L0 .. 6 + L1)        := Timeout_S;
 335          Trace_S (7 + L1 .. 9 + L1)        := "/#:";
 336          Trace_S (10 + L1 .. 9 + L2)       := Number_S;
 337          Trace_S (10 + L2 .. 12 + L2)      := "/E:";
 338          Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
 339          Send_Trace (Id, Trace_S);
 340       end if;
 341    end Send_Trace_Info;
 342
 343    ---------------------
 344    -- Extract_Accepts --
 345    ---------------------
 346
 347    --  This function returns a string in which all opened
 348    --  Accepts or Selects are given, separated by semi-colons.
 349
 350    function Extract_Accepts (Task_Name : Task_Id) return String_Trace is
 351       Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
 352
 353    begin
 354       for J in Task_Name.Open_Accepts'First ..
 355         Task_Name.Open_Accepts'Last - 1
 356       loop
 357          Info_Annex := Append (Info_Annex, Integer'Image
 358                                (Integer (Task_Name.Open_Accepts (J).S)) & ",");
 359       end loop;
 360
 361       Info_Annex := Append (Info_Annex,
 362                             Integer'Image (Integer
 363                                            (Task_Name.Open_Accepts
 364                                             (Task_Name.Open_Accepts'Last).S)));
 365       return Info_Annex;
 366    end Extract_Accepts;
 367 end System.Traces.Tasking;