From 1bc5aee63eb72b341f506ad058502cd0361f0d10 Mon Sep 17 00:00:00 2001 From: Ben Cheng Date: Tue, 25 Mar 2014 22:37:19 -0700 Subject: Initial checkin of GCC 4.9.0 from trunk (r208799). Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba --- gcc-4.9/gcc/ada/s-tratas-default.adb | 365 +++++++++++++++++++++++++++++++++++ 1 file changed, 365 insertions(+) create mode 100644 gcc-4.9/gcc/ada/s-tratas-default.adb (limited to 'gcc-4.9/gcc/ada/s-tratas-default.adb') diff --git a/gcc-4.9/gcc/ada/s-tratas-default.adb b/gcc-4.9/gcc/ada/s-tratas-default.adb new file mode 100644 index 000000000..0c80fe96d --- /dev/null +++ b/gcc-4.9/gcc/ada/s-tratas-default.adb @@ -0,0 +1,365 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; use System.Tasking; +with System.Soft_Links; +with System.Parameters; +with System.Traces.Format; use System.Traces.Format; +with System.Traces; use System.Traces; + +package body System.Traces.Tasking is + + use System.Traces; + + package SSL renames System.Soft_Links; + + function Extract_Accepts (Task_Name : Task_Id) return String_Trace; + -- This function is used to extract data joined with + -- W_Select, WT_Select, W_Accept events + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_RDV_Complete | PO_Done => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/C:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Missed => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Kill => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when T_Create => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : Task_Id; + Entry_Number : Entry_Index) + is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + L2 : constant Integer := Task_S'Length + Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_Accept_Complete => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when W_Call => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L2) := Task2_S; + Trace_S (7 + L2 .. 9 + L2) := "/C:"; + Trace_S (10 + L2 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Task_Name2 : Task_Id; + Entry_Number : Entry_Index) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when PO_Run => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is + Task_S : constant String := SSL.Task_Name.all; + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length); + + L0 : constant Integer := Task_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Task_Name2 : Task_Id) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : constant Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task2_S; + Trace_S (4 + L0 .. 6 + L0) := "/P:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : Task_Id; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Acceptor_S : constant String := + Acceptor.Common.Task_Image + (1 .. Acceptor.Common.Task_Image_Len); + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Timeout_S : constant String := Duration'Image (Timeout); + Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Acceptor_S'Length; + L2 : constant Integer := + Task_S'Length + Acceptor_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L1) := Acceptor_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. 9 + L2) := Entry_S; + Trace_S (10 + L2 .. 12 + L2) := "/T:"; + Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Entry_S : constant String := Integer'Image (Integer (Entry_Number)); + Timeout_S : constant String := Duration'Image (Timeout); + Trace_S : String (1 .. 9 + Task_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/T:"; + Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Number : Integer) + is + Task_S : constant String := SSL.Task_Name.all; + Number_S : constant String := Integer'Image (Number); + Accepts_S : constant String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 9 + Task_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/#:"; + Trace_S (7 + L0 .. 6 + L1) := Number_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_Id; + Number : Integer; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Timeout_S : constant String := Duration'Image (Timeout); + Number_S : constant String := Integer'Image (Number); + Accepts_S : constant String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : constant Integer := Task_S'Length; + L1 : constant Integer := Task_S'Length + Timeout_S'Length; + L2 : constant Integer := + Task_S'Length + Timeout_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/T:"; + Trace_S (7 + L0 .. 6 + L1) := Timeout_S; + Trace_S (7 + L1 .. 9 + L1) := "/#:"; + Trace_S (10 + L1 .. 9 + L2) := Number_S; + Trace_S (10 + L2 .. 12 + L2) := "/E:"; + Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + --------------------- + -- Extract_Accepts -- + --------------------- + + -- This function returns a string in which all opened + -- Accepts or Selects are given, separated by semi-colons. + + function Extract_Accepts (Task_Name : Task_Id) return String_Trace is + Info_Annex : String_Trace := (ASCII.NUL, others => ' '); + + begin + for J in Task_Name.Open_Accepts'First .. + Task_Name.Open_Accepts'Last - 1 + loop + Info_Annex := Append (Info_Annex, Integer'Image + (Integer (Task_Name.Open_Accepts (J).S)) & ","); + end loop; + + Info_Annex := Append (Info_Annex, + Integer'Image (Integer + (Task_Name.Open_Accepts + (Task_Name.Open_Accepts'Last).S))); + return Info_Annex; + end Extract_Accepts; +end System.Traces.Tasking; -- cgit v1.2.3