gcc/ada/s-tratas-default.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT 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-2005 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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.Traces;
  43
  44    package SSL renames System.Soft_Links;
  45
  46    function Extract_Accepts (Task_Name : Task_Id) return String_Trace;
  47    --  This function is used to extract data joined with
  48    --  W_Select, WT_Select, W_Accept events
  49
  50    ---------------------
  51    -- Send_Trace_Info --
  52    ---------------------
  53
  54    procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is
  55       Task_S  : constant String := SSL.Task_Name.all;
  56       Task2_S : constant String :=
  57                   Task_Name2.Common.Task_Image
  58                     (1 .. Task_Name2.Common.Task_Image_Len);
  59       Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
  60
  61       L0 : constant Integer := Task_S'Length;
  62       L1 : constant Integer := Task2_S'Length;
  63
  64    begin
  65       if Parameters.Runtime_Traces then
  66          case Id is
  67             when M_RDV_Complete | PO_Done =>
  68                Trace_S (1 .. 3)                 := "/N:";
  69                Trace_S (4 .. 3 + L0)            := Task_S;
  70                Trace_S (4 + L0 .. 6 + L0)       := "/C:";
  71                Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
  72                Send_Trace (Id, Trace_S);
  73
  74             when E_Missed =>
  75                Trace_S (1 .. 3)                 := "/N:";
  76                Trace_S (4 .. 3 + L0)            := Task_S;
  77                Trace_S (4 + L0 .. 6 + L0)       := "/A:";
  78                Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
  79                Send_Trace (Id, Trace_S);
  80
  81             when E_Kill =>
  82                Trace_S (1 .. 3)                 := "/N:";
  83                Trace_S (4 .. 3 + L1)            := Task2_S;
  84                Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
  85                Send_Trace (Id, Trace_S);
  86
  87             when T_Create =>
  88                Trace_S (1 .. 3)                 := "/N:";
  89                Trace_S (4 .. 3 + L1)            := Task2_S;
  90                Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
  91                Send_Trace (Id, Trace_S);
  92
  93             when others =>
  94                null;
  95                --  should raise an exception ???
  96          end case;
  97       end if;
  98    end Send_Trace_Info;
  99
 100    procedure Send_Trace_Info
 101      (Id           : Trace_T;
 102       Task_Name2   : Task_Id;
 103       Entry_Number : Entry_Index)
 104    is
 105       Task_S  : constant String := SSL.Task_Name.all;
 106       Task2_S : constant String :=
 107                   Task_Name2.Common.Task_Image
 108                     (1 .. Task_Name2.Common.Task_Image_Len);
 109       Entry_S   : constant String := Integer'Image (Integer (Entry_Number));
 110       Trace_S   : String (1 .. 9 + Task_S'Length
 111                                  + Task2_S'Length + Entry_S'Length);
 112
 113       L0 : constant Integer := Task_S'Length;
 114       L1 : constant Integer := Task_S'Length + Entry_S'Length;
 115       L2 : constant Integer := Task_S'Length + Task2_S'Length;
 116
 117    begin
 118       if Parameters.Runtime_Traces then
 119          case Id is
 120             when M_Accept_Complete =>
 121                Trace_S (1 .. 3)                  := "/N:";
 122                Trace_S (4 .. 3 + L0)             := Task_S;
 123                Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 124                Trace_S (7 + L0 .. 6 + L1)         := Entry_S;
 125                Trace_S (7 + L1 .. 9 + L1)        := "/C:";
 126                Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
 127                Send_Trace (Id, Trace_S);
 128
 129             when W_Call =>
 130                Trace_S (1 .. 3)                  := "/N:";
 131                Trace_S (4 .. 3 + L0)             := Task_S;
 132                Trace_S (4 + L0 .. 6 + L0)        := "/A:";
 133                Trace_S (7 + L0 .. 6 + L2)        := Task2_S;
 134                Trace_S (7 + L2 .. 9 + L2)        := "/C:";
 135                Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
 136                Send_Trace (Id, Trace_S);
 137
 138             when others =>
 139                null;
 140                --  should raise an exception ???
 141          end case;
 142       end if;
 143    end Send_Trace_Info;
 144
 145    procedure Send_Trace_Info
 146      (Id           : Trace_T;
 147       Task_Name    : Task_Id;
 148       Task_Name2   : Task_Id;
 149       Entry_Number : Entry_Index)
 150    is
 151       Task_S  : constant String :=
 152                   Task_Name.Common.Task_Image
 153                     (1 .. Task_Name.Common.Task_Image_Len);
 154       Task2_S : constant String :=
 155                   Task_Name2.Common.Task_Image
 156                     (1 .. Task_Name2.Common.Task_Image_Len);
 157       Entry_S   : constant String := Integer'Image (Integer (Entry_Number));
 158       Trace_S   : String (1 .. 9 + Task_S'Length
 159                                  + Task2_S'Length + Entry_S'Length);
 160
 161       L0 : constant Integer := Task_S'Length;
 162       L1 : constant Integer := Task_S'Length + Entry_S'Length;
 163
 164    begin
 165       if Parameters.Runtime_Traces then
 166          case Id is
 167             when PO_Run =>
 168                Trace_S (1 .. 3)                  := "/N:";
 169                Trace_S (4 .. 3 + L0)             := Task_S;
 170                Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 171                Trace_S (7 + L0 .. 6 + L1)        := Entry_S;
 172                Trace_S (7 + L1 .. 9 + L1)        := "/C:";
 173                Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
 174                Send_Trace (Id, Trace_S);
 175
 176             when others =>
 177                null;
 178                --  should raise an exception ???
 179          end case;
 180       end if;
 181    end Send_Trace_Info;
 182
 183    procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
 184       Task_S  : constant String := SSL.Task_Name.all;
 185       Entry_S : constant String := Integer'Image (Integer (Entry_Number));
 186       Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
 187
 188       L0 : constant Integer := Task_S'Length;
 189
 190    begin
 191       if Parameters.Runtime_Traces then
 192          Trace_S (1 .. 3)                 := "/N:";
 193          Trace_S (4 .. 3 + L0)            := Task_S;
 194          Trace_S (4 + L0 .. 6 + L0)       := "/E:";
 195          Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
 196          Send_Trace (Id, Trace_S);
 197       end if;
 198    end Send_Trace_Info;
 199
 200    procedure Send_Trace_Info
 201      (Id         : Trace_T;
 202       Task_Name  : Task_Id;
 203       Task_Name2 : Task_Id)
 204    is
 205       Task_S  : constant String :=
 206                   Task_Name.Common.Task_Image
 207                     (1 .. Task_Name.Common.Task_Image_Len);
 208       Task2_S : constant String :=
 209                   Task_Name2.Common.Task_Image
 210                     (1 .. Task_Name2.Common.Task_Image_Len);
 211       Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
 212
 213       L0 : constant Integer := Task2_S'Length;
 214
 215    begin
 216       if Parameters.Runtime_Traces then
 217          Trace_S (1 .. 3)                 := "/N:";
 218          Trace_S (4 .. 3 + L0)            := Task2_S;
 219          Trace_S (4 + L0 .. 6 + L0)       := "/P:";
 220          Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
 221          Send_Trace (Id, Trace_S);
 222       end if;
 223    end Send_Trace_Info;
 224
 225    procedure Send_Trace_Info
 226      (Id           : Trace_T;
 227       Acceptor     : Task_Id;
 228       Entry_Number : Entry_Index;
 229       Timeout      : Duration)
 230    is
 231       Task_S     : constant String := SSL.Task_Name.all;
 232       Acceptor_S : constant String :=
 233                      Acceptor.Common.Task_Image
 234                        (1 .. Acceptor.Common.Task_Image_Len);
 235       Entry_S    : constant String := Integer'Image (Integer (Entry_Number));
 236       Timeout_S  : constant String := Duration'Image (Timeout);
 237       Trace_S    : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
 238                                    + Entry_S'Length + Timeout_S'Length);
 239
 240       L0 : constant Integer := Task_S'Length;
 241       L1 : constant Integer := Task_S'Length + Acceptor_S'Length;
 242       L2 : constant Integer :=
 243              Task_S'Length + Acceptor_S'Length + Entry_S'Length;
 244
 245    begin
 246       if Parameters.Runtime_Traces then
 247          Trace_S (1 .. 3)                  := "/N:";
 248          Trace_S (4 .. 3 + L0)             := Task_S;
 249          Trace_S (4 + L0 .. 6 + L0)        := "/A:";
 250          Trace_S (7 + L0 .. 6 + L1)        := Acceptor_S;
 251          Trace_S (7 + L1 .. 9 + L1)        := "/E:";
 252          Trace_S (10 + L1 .. 9 + L2)       := Entry_S;
 253          Trace_S (10 + L2 .. 12 + L2)      := "/T:";
 254          Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
 255          Send_Trace (Id, Trace_S);
 256       end if;
 257    end Send_Trace_Info;
 258
 259    procedure Send_Trace_Info
 260      (Id           : Trace_T;
 261       Entry_Number : Entry_Index;
 262       Timeout      : Duration)
 263    is
 264       Task_S    : constant String := SSL.Task_Name.all;
 265       Entry_S   : constant String := Integer'Image (Integer (Entry_Number));
 266       Timeout_S : constant String := Duration'Image (Timeout);
 267       Trace_S   : String (1 .. 9 + Task_S'Length
 268                                  + Entry_S'Length + Timeout_S'Length);
 269
 270       L0 : constant Integer := Task_S'Length;
 271       L1 : constant Integer := Task_S'Length + Entry_S'Length;
 272
 273    begin
 274       if Parameters.Runtime_Traces then
 275          Trace_S (1 .. 3)                  := "/N:";
 276          Trace_S (4 .. 3 + L0)             := Task_S;
 277          Trace_S (4 + L0 .. 6 + L0)        := "/E:";
 278          Trace_S (7 + L0 .. 6 + L1)        := Entry_S;
 279          Trace_S (7 + L1 .. 9 + L1)        := "/T:";
 280          Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
 281          Send_Trace (Id, Trace_S);
 282       end if;
 283    end Send_Trace_Info;
 284
 285    procedure Send_Trace_Info
 286      (Id        : Trace_T;
 287       Task_Name : Task_Id;
 288       Number    : Integer)
 289    is
 290       Task_S    : constant String := SSL.Task_Name.all;
 291       Number_S  : constant String := Integer'Image (Number);
 292       Accepts_S : constant String := Extract_Accepts (Task_Name);
 293       Trace_S   : String (1 .. 9 + Task_S'Length
 294                                  + Number_S'Length + Accepts_S'Length);
 295
 296       L0 : constant Integer := Task_S'Length;
 297       L1 : constant Integer := Task_S'Length + Number_S'Length;
 298
 299    begin
 300       if Parameters.Runtime_Traces then
 301          Trace_S (1 .. 3)                  := "/N:";
 302          Trace_S (4 .. 3 + L0)             := Task_S;
 303          Trace_S (4 + L0 .. 6 + L0)        := "/#:";
 304          Trace_S (7 + L0 .. 6 + L1)        := Number_S;
 305          Trace_S (7 + L1 .. 9 + L1)        := "/E:";
 306          Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
 307          Send_Trace (Id, Trace_S);
 308       end if;
 309    end Send_Trace_Info;
 310
 311    procedure Send_Trace_Info
 312      (Id        : Trace_T;
 313       Task_Name : Task_Id;
 314       Number    : Integer;
 315       Timeout   : Duration)
 316    is
 317       Task_S    : constant String := SSL.Task_Name.all;
 318       Timeout_S : constant String := Duration'Image (Timeout);
 319       Number_S  : constant String := Integer'Image (Number);
 320       Accepts_S : constant String := Extract_Accepts (Task_Name);
 321       Trace_S   : String (1 .. 12 + Task_S'Length + Timeout_S'Length
 322                                   + Number_S'Length + Accepts_S'Length);
 323
 324       L0 : constant Integer := Task_S'Length;
 325       L1 : constant Integer := Task_S'Length + Timeout_S'Length;
 326       L2 : constant Integer :=
 327              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;