From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-tasdeb.adb | 373 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 373 insertions(+) create mode 100644 gcc/ada/s-tasdeb.adb (limited to 'gcc/ada/s-tasdeb.adb') diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb new file mode 100644 index 000000000..ccc81d9d5 --- /dev/null +++ b/gcc/ada/s-tasdeb.adb @@ -0,0 +1,373 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode. + +-- Note : This file *must* be compiled with debugging information + +-- Do not add any dependency to GNARL packages since this package is used +-- in both normal and restricted (ravenscar) environments. + +with System.CRTL; +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with Ada.Unchecked_Conversion; + +package body System.Tasking.Debug is + + package STPO renames System.Task_Primitives.Operations; + + function To_Integer is new + Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); + + type Trace_Flag_Set is array (Character) of Boolean; + + Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Write (Fd : Integer; S : String; Count : Integer); + + procedure Put (S : String); + -- Display S on standard output + + procedure Put_Line (S : String := ""); + -- Display S on standard output with an additional line terminator + + ------------------------ + -- Continue_All_Tasks -- + ------------------------ + + procedure Continue_All_Tasks is + C : Task_Id; + + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Continue_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Continue_All_Tasks; + + -------------------- + -- Get_User_State -- + -------------------- + + function Get_User_State return Long_Integer is + begin + return STPO.Self.User_State; + end Get_User_State; + + ---------------- + -- List_Tasks -- + ---------------- + + procedure List_Tasks is + C : Task_Id; + begin + C := All_Tasks_List; + + while C /= null loop + Print_Task_Info (C); + C := C.Common.All_Tasks_Link; + end loop; + end List_Tasks; + + ------------------------ + -- Print_Current_Task -- + ------------------------ + + procedure Print_Current_Task is + begin + Print_Task_Info (STPO.Self); + end Print_Current_Task; + + --------------------- + -- Print_Task_Info -- + --------------------- + + procedure Print_Task_Info (T : Task_Id) is + Entry_Call : Entry_Call_Link; + Parent : Task_Id; + + begin + if T = null then + Put_Line ("null task"); + return; + end if; + + Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " & + Task_States'Image (T.Common.State)); + + Parent := T.Common.Parent; + + if Parent = null then + Put (", parent: "); + else + Put (", parent: " & + Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len)); + end if; + + Put (", prio:" & T.Common.Current_Priority'Img); + + if not T.Callable then + Put (", not callable"); + end if; + + if T.Aborting then + Put (", aborting"); + end if; + + if T.Deferral_Level /= 0 then + Put (", abort deferred"); + end if; + + if T.Common.Call /= null then + Entry_Call := T.Common.Call; + Put (", serving:"); + + while Entry_Call /= null loop + Put (To_Integer (Entry_Call.Self)'Img); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + end if; + + if T.Open_Accepts /= null then + Put (", accepting:"); + + for J in T.Open_Accepts'Range loop + Put (T.Open_Accepts (J).S'Img); + end loop; + + if T.Terminate_Alternative then + Put (" or terminate"); + end if; + end if; + + if T.User_State /= 0 then + Put (", state:" & T.User_State'Img); + end if; + + Put_Line; + end Print_Task_Info; + + --------- + -- Put -- + --------- + + procedure Put (S : String) is + begin + Write (2, S, S'Length); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String := "") is + begin + Write (2, S & ASCII.LF, S'Length + 1); + end Put_Line; + + ---------------------- + -- Resume_All_Tasks -- + ---------------------- + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + C := All_Tasks_List; + + while C /= null loop + Dummy := STPO.Resume_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Resume_All_Tasks; + + --------------- + -- Set_Trace -- + --------------- + + procedure Set_Trace (Flag : Character; Value : Boolean := True) is + begin + Trace_On (Flag) := Value; + end Set_Trace; + + -------------------- + -- Set_User_State -- + -------------------- + + procedure Set_User_State (Value : Long_Integer) is + begin + STPO.Self.User_State := Value; + end Set_User_State; + + ------------------------ + -- Signal_Debug_Event -- + ------------------------ + + procedure Signal_Debug_Event + (Event_Kind : Event_Kind_Type; + Task_Value : Task_Id) + is + begin + null; + end Signal_Debug_Event; + + -------------------- + -- Stop_All_Tasks -- + -------------------- + + procedure Stop_All_Tasks is + C : Task_Id; + + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + + C := All_Tasks_List; + while C /= null loop + Dummy := STPO.Stop_Task (C); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Stop_All_Tasks; + + ---------------------------- + -- Stop_All_Tasks_Handler -- + ---------------------------- + + procedure Stop_All_Tasks_Handler is + begin + STPO.Stop_All_Tasks; + end Stop_All_Tasks_Handler; + + ----------------------- + -- Suspend_All_Tasks -- + ----------------------- + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : Task_Id; + Dummy : Boolean; + pragma Unreferenced (Dummy); + + begin + STPO.Lock_RTS; + C := All_Tasks_List; + + while C /= null loop + Dummy := STPO.Suspend_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + + STPO.Unlock_RTS; + end Suspend_All_Tasks; + + ------------------------ + -- Task_Creation_Hook -- + ------------------------ + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is + pragma Inspection_Point (Thread); + -- gdb needs to access the thread parameter in order to implement + -- the multitask mode under VxWorks. + + begin + null; + end Task_Creation_Hook; + + --------------------------- + -- Task_Termination_Hook -- + --------------------------- + + procedure Task_Termination_Hook is + begin + null; + end Task_Termination_Hook; + + ----------- + -- Trace -- + ----------- + + procedure Trace + (Self_Id : Task_Id; + Msg : String; + Flag : Character; + Other_Id : Task_Id := null) + is + begin + if Trace_On (Flag) then + Put (To_Integer (Self_Id)'Img & + ':' & Flag & ':' & + Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) & + ':'); + + if Other_Id /= null then + Put (To_Integer (Other_Id)'Img & ':'); + end if; + + Put_Line (Msg); + end if; + end Trace; + + ----------- + -- Write -- + ----------- + + procedure Write (Fd : Integer; S : String; Count : Integer) is + Discard : System.CRTL.ssize_t; + pragma Unreferenced (Discard); + begin + Discard := System.CRTL.write (Fd, S (S'First)'Address, + System.CRTL.size_t (Count)); + -- Is it really right to ignore write errors here ??? + end Write; + +end System.Tasking.Debug; -- cgit v1.2.3