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