gcc/ada/5gtpgetc.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . G E N _ T C B I N F    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.5 $
  10 --                                                                          --
  11 --              Copyright (C) 1999-2000 Free Software Fundation             --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNARL was developed by the GNARL team at Florida State University. It is --
  32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  33 -- State University (http://www.gnat.com).                                  --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 --  This is an SGI Irix version of this package
  38
  39 --  This procedure creates the file "a-tcbinf.c"
  40 --  "A-tcbinf.c" is subsequently compiled and made part of the RTL
  41 --  to be referenced by the SGI Workshop debugger. The main procedure:
  42 --  "Gen_Tcbinf" imports this child procedure and runs as part of the
  43 --  RTL build process. Because of the complex process used to build
  44 --  the GNAT RTL for all the different systems and the frequent changes
  45 --  made to the internal data structures, its impractical to create
  46 --  "a-tcbinf.c" using a standalone process.
  47 with System.Tasking;
  48 with Ada.Text_IO;
  49 with Unchecked_Conversion;
  50
  51 procedure System.Task_Primitives.Gen_Tcbinf is
  52
  53    use System.Tasking;
  54
  55    subtype Version_String is String (1 .. 4);
  56
  57    Version : constant Version_String := "3.11";
  58
  59    function To_Integer is new Unchecked_Conversion
  60      (Version_String, Integer);
  61
  62    type Dummy_TCB_Ptr is access Ada_Task_Control_Block (Entry_Num => 0);
  63    Dummy_TCB : constant Dummy_TCB_Ptr := new Ada_Task_Control_Block (0);
  64
  65    C_File : Ada.Text_IO.File_Type;
  66
  67    procedure Pl (S : String);
  68    procedure Nl (C : Ada.Text_IO.Positive_Count := 1);
  69    function State_Name (S : Task_States) return String;
  70
  71    procedure Pl (S : String) is
  72    begin
  73       Ada.Text_IO.Put_Line (C_File, S);
  74    end Pl;
  75
  76    procedure Nl (C : Ada.Text_IO.Positive_Count := 1) is
  77    begin
  78       Ada.Text_IO.New_Line (C_File, C);
  79    end Nl;
  80
  81    function State_Name (S : Task_States) return String is
  82    begin
  83       case S is
  84          when Unactivated =>
  85             return "Unactivated";
  86          when Runnable =>
  87             return "Runnable";
  88          when Terminated =>
  89             return "Terminated";
  90          when Activator_Sleep =>
  91             return "Child Activation Wait";
  92          when Acceptor_Sleep =>
  93             return "Accept/Select Wait";
  94          when Entry_Caller_Sleep =>
  95             return "Waiting on Entry Call";
  96          when Async_Select_Sleep =>
  97             return "Async_Select Wait";
  98          when Delay_Sleep =>
  99             return "Delay Sleep";
 100          when Master_Completion_Sleep =>
 101             return "Child Termination Wait";
 102          when Master_Phase_2_Sleep =>
 103             return "Wait Child in Term Alt";
 104          when Interrupt_Server_Idle_Sleep =>
 105             return "Int Server Idle Sleep";
 106          when Interrupt_Server_Blocked_Interrupt_Sleep =>
 107             return "Int Server Blk Int Sleep";
 108          when Timer_Server_Sleep =>
 109             return "Timer Server Sleep";
 110          when AST_Server_Sleep =>
 111             return "AST Server Sleep";
 112          when Asynchronous_Hold =>
 113             return "Asynchronous Hold";
 114          when Interrupt_Server_Blocked_On_Event_Flag =>
 115             return "Int Server Blk Evt Flag";
 116       end case;
 117    end State_Name;
 118
 119    All_Tasks_Link_Offset   : constant Integer
 120      := Dummy_TCB.Common'Position + Dummy_TCB.Common.All_Tasks_Link'Position;
 121    Entry_Count_Offset      : constant Integer
 122      := Dummy_TCB.Entry_Num'Position;
 123    Entry_Point_Offset      : constant Integer
 124      := Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Entry_Point'Position;
 125    Parent_Offset           : constant Integer
 126      := Dummy_TCB.Common'Position + Dummy_TCB.Common.Parent'Position;
 127    Base_Priority_Offset    : constant Integer
 128      := Dummy_TCB.Common'Position + Dummy_TCB.Common.Base_Priority'Position;
 129    Current_Priority_Offset : constant Integer
 130      := Dummy_TCB.Common'Position + Dummy_TCB.Common.Current_Priority'Position;
 131    Stack_Size_Offset       : constant Integer
 132      := Dummy_TCB.Common'Position +
 133        Dummy_TCB.Common.Compiler_Data.Pri_Stack_Info.Size'Position;
 134    State_Offset            : constant Integer
 135      := Dummy_TCB.Common'Position + Dummy_TCB.Common.State'Position;
 136    Task_Image_Offset       : constant Integer
 137      := Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Image'Position;
 138    Thread_Offset           : constant Integer
 139      := Dummy_TCB.Common'Position + Dummy_TCB.Common.LL'Position +
 140         Dummy_TCB.Common.LL.Thread'Position;
 141
 142 begin
 143
 144    Ada.Text_IO.Create (C_File, Ada.Text_IO.Out_File, "a-tcbinf.c");
 145
 146    Pl ("");
 147    Pl ("#include <sys/types.h>");
 148    Pl ("");
 149    Pl ("#define TCB_INFO_VERSION 2");
 150    Pl ("#define TCB_LIBRARY_VERSION "
 151      & Integer'Image (To_Integer (Version)));
 152    Pl ("");
 153    Pl ("typedef struct {");
 154    Pl ("");
 155    Pl ("   __uint32_t   info_version;");
 156    Pl ("   __uint32_t   library_version;");
 157    Pl ("");
 158    Pl ("   __uint32_t   All_Tasks_Link_Offset;");
 159    Pl ("   __uint32_t   Entry_Count_Offset;");
 160    Pl ("   __uint32_t   Entry_Point_Offset;");
 161    Pl ("   __uint32_t   Parent_Offset;");
 162    Pl ("   __uint32_t   Base_Priority_Offset;");
 163    Pl ("   __uint32_t   Current_Priority_Offset;");
 164    Pl ("   __uint32_t   Stack_Size_Offset;");
 165    Pl ("   __uint32_t   State_Offset;");
 166    Pl ("   __uint32_t   Task_Image_Offset;");
 167    Pl ("   __uint32_t   Thread_Offset;");
 168    Pl ("");
 169    Pl ("   char         **state_names;");
 170    Pl ("   __uint32_t   state_names_max;");
 171    Pl ("");
 172    Pl ("} task_control_block_info_t;");
 173    Pl ("");
 174    Pl ("static char *accepting_state_names = NULL;");
 175
 176    Pl ("");
 177    Pl ("static char *task_state_names[] = {");
 178
 179    for State in Task_States loop
 180       Pl ("   """ & State_Name (State) & """,");
 181    end loop;
 182    Pl ("   """"};");
 183
 184    Pl ("");
 185    Pl ("");
 186    Pl ("task_control_block_info_t __task_control_block_info = {");
 187    Pl ("");
 188    Pl ("   TCB_INFO_VERSION,");
 189    Pl ("   TCB_LIBRARY_VERSION,");
 190    Pl ("");
 191    Pl ("   " & All_Tasks_Link_Offset'Img & ",");
 192    Pl ("   " & Entry_Count_Offset'Img & ",");
 193    Pl ("   " & Entry_Point_Offset'Img & ",");
 194    Pl ("   " & Parent_Offset'Img & ",");
 195    Pl ("   " & Base_Priority_Offset'Img & ",");
 196    Pl ("   " & Current_Priority_Offset'Img & ",");
 197    Pl ("   " & Stack_Size_Offset'Img & ",");
 198    Pl ("   " & State_Offset'Img & ",");
 199    Pl ("   " & Task_Image_Offset'Img & ",");
 200    Pl ("   " & Thread_Offset'Img & ",");
 201    Pl ("");
 202    Pl ("   task_state_names,");
 203    Pl ("   sizeof (task_state_names),");
 204    Pl ("");
 205    Pl ("");
 206    Pl ("};");
 207
 208    Ada.Text_IO.Close (C_File);
 209
 210 end System.Task_Primitives.Gen_Tcbinf;