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