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