diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/s-tasdeb.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/s-tasdeb.adb | 407 |
1 files changed, 407 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/s-tasdeb.adb b/gcc-4.9/gcc/ada/s-tasdeb.adb new file mode 100644 index 000000000..2c8b63849 --- /dev/null +++ b/gcc-4.9/gcc/ada/s-tasdeb.adb @@ -0,0 +1,407 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2013, 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 -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- 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.Address_Image; +with System.CRTL; +with System.Task_Primitives; +with System.Task_Primitives.Operations; + +package body System.Tasking.Debug is + + package STPO renames System.Task_Primitives.Operations; + + type Trace_Flag_Set is array (Character) of Boolean; + + Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); + + Stderr_Fd : constant := 2; + -- File descriptor for standard error + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Write (Fd : Integer; S : String; Count : Integer); + -- Write Count characters of S to the file descriptor Fd + + procedure Put (S : String); + -- Display S on standard error + + procedure Put_Line (S : String := ""); + -- Display S on standard error with an additional line terminator + + function Task_Image (T : Task_Id) return String; + -- Return the relevant characters from T.Common.Task_Image + + function Task_Id_Image (T : Task_Id) return String; + -- Return the address in hexadecimal form + + ------------------------ + -- 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 (Task_Image (T) & ": " & Task_States'Image (T.Common.State)); + Parent := T.Common.Parent; + + if Parent = null then + Put (", parent: <none>"); + else + Put (", parent: " & Task_Image (Parent)); + 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 (Task_Id_Image (Entry_Call.Self)); + 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 (Stderr_Fd, S, S'Length); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String := "") is + begin + Write (Stderr_Fd, 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_Id_Image -- + ---------------- + + function Task_Id_Image (T : Task_Id) return String is + begin + if T = null then + return "Null_Task_Id"; + else + return Address_Image (T.all'Address); + end if; + end Task_Id_Image; + + ---------------- + -- Task_Image -- + ---------------- + + function Task_Image (T : Task_Id) return String is + begin + -- In case T.Common.Task_Image_Len is uninitialized junk, we check that + -- it is in range, to make this more robust. + + if T.Common.Task_Image_Len in T.Common.Task_Image'Range then + return T.Common.Task_Image (1 .. T.Common.Task_Image_Len); + else + return T.Common.Task_Image; + end if; + end Task_Image; + + --------------------------- + -- 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 (Task_Id_Image (Self_Id) & + ':' & Flag & ':' & + Task_Image (Self_Id) & + ':'); + + if Other_Id /= null then + Put (Task_Id_Image (Other_Id) & ':'); + 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'Address, + System.CRTL.size_t (Count)); + -- Ignore write errors here; this is just debugging output, and there's + -- nothing to be done about errors anyway. + end Write; + +end System.Tasking.Debug; |