gcc/ada/libgnat/s-thread__ae653.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . T H R E A D S                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the VxWorks 653 version of this package
  33
  34 pragma Restrictions (No_Tasking);
  35 --  The VxWorks 653 version of this package is intended only for programs
  36 --  which do not use Ada tasking. This restriction ensures that this
  37 --  will be checked by the binder.
  38
  39 with System.OS_Versions; use System.OS_Versions;
  40
  41 package body System.Threads is
  42
  43    use Interfaces.C;
  44
  45    package SSL renames System.Soft_Links;
  46
  47    Current_ATSD : aliased System.Address := System.Null_Address;
  48    pragma Export (C, Current_ATSD, "__gnat_current_atsd");
  49
  50    Main_ATSD : aliased ATSD;
  51    --  TSD for environment task
  52
  53    Stack_Limit : Address;
  54
  55    pragma Import (C, Stack_Limit, "__gnat_stack_limit");
  56
  57    type Set_Stack_Limit_Proc_Acc is access procedure;
  58    pragma Convention (C, Set_Stack_Limit_Proc_Acc);
  59
  60    Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
  61    pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
  62    --  Procedure to be called when a task is created to set stack limit if
  63    --  limit checking is used.
  64
  65    --------------------------
  66    -- VxWorks specific API --
  67    --------------------------
  68
  69    ERROR : constant STATUS := Interfaces.C.int (-1);
  70
  71    function taskIdVerify (tid : t_id) return STATUS;
  72    pragma Import (C, taskIdVerify, "taskIdVerify");
  73
  74    function taskIdSelf return t_id;
  75    pragma Import (C, taskIdSelf, "taskIdSelf");
  76
  77    function taskVarAdd
  78      (tid : t_id; pVar : System.Address) return int;
  79    pragma Import (C, taskVarAdd, "taskVarAdd");
  80
  81    -----------------------
  82    -- Local Subprograms --
  83    -----------------------
  84
  85    procedure Init_RTS;
  86    --  This procedure performs the initialization of the run-time lib.
  87    --  It installs System.Threads versions of certain operations of the
  88    --  run-time lib.
  89
  90    procedure Install_Handler;
  91    pragma Import (C, Install_Handler, "__gnat_install_handler");
  92
  93    function  Get_Sec_Stack return SST.SS_Stack_Ptr;
  94
  95    procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr);
  96
  97    -----------------------
  98    -- Thread_Body_Enter --
  99    -----------------------
 100
 101    procedure Thread_Body_Enter
 102      (Sec_Stack_Ptr        : SST.SS_Stack_Ptr;
 103       Process_ATSD_Address : System.Address)
 104    is
 105       --  Current_ATSD must already be a taskVar of taskIdSelf.
 106       --  No assertion because taskVarGet is not available on VxWorks/CERT,
 107       --  which is used on VxWorks 653 3.x as a guest OS.
 108
 109       TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
 110
 111    begin
 112
 113       TSD.Sec_Stack_Ptr := Sec_Stack_Ptr;
 114       SST.SS_Init (TSD.Sec_Stack_Ptr);
 115       Current_ATSD := Process_ATSD_Address;
 116
 117       Install_Handler;
 118
 119       --  Initialize stack limit if needed
 120
 121       if Current_ATSD /= Main_ATSD'Address
 122         and then Set_Stack_Limit_Hook /= null
 123       then
 124          Set_Stack_Limit_Hook.all;
 125       end if;
 126    end Thread_Body_Enter;
 127
 128    ----------------------------------
 129    -- Thread_Body_Exceptional_Exit --
 130    ----------------------------------
 131
 132    procedure Thread_Body_Exceptional_Exit
 133      (EO : Ada.Exceptions.Exception_Occurrence)
 134    is
 135       pragma Unreferenced (EO);
 136
 137    begin
 138       --  No action for this target
 139
 140       null;
 141    end Thread_Body_Exceptional_Exit;
 142
 143    -----------------------
 144    -- Thread_Body_Leave --
 145    -----------------------
 146
 147    procedure Thread_Body_Leave is
 148    begin
 149       --  No action for this target
 150
 151       null;
 152    end Thread_Body_Leave;
 153
 154    --------------
 155    -- Init_RTS --
 156    --------------
 157
 158    procedure Init_RTS is
 159       --  Register environment task
 160       Result : constant Interfaces.C.int := Register (taskIdSelf);
 161       pragma Assert (Result /= ERROR);
 162
 163    begin
 164       Main_ATSD.Sec_Stack_Ptr := SSL.Get_Sec_Stack_NT;
 165       Current_ATSD := Main_ATSD'Address;
 166       Install_Handler;
 167       SSL.Get_Sec_Stack := Get_Sec_Stack'Access;
 168       SSL.Set_Sec_Stack := Set_Sec_Stack'Access;
 169    end Init_RTS;
 170
 171    -------------------
 172    -- Get_Sec_Stack --
 173    -------------------
 174
 175    function  Get_Sec_Stack return SST.SS_Stack_Ptr is
 176       CTSD : constant ATSD_Access := From_Address (Current_ATSD);
 177    begin
 178       pragma Assert (CTSD /= null);
 179       return CTSD.Sec_Stack_Ptr;
 180    end Get_Sec_Stack;
 181
 182    --------------
 183    -- Register --
 184    --------------
 185
 186    function Register (T : Thread_Id) return STATUS is
 187       Result : STATUS;
 188
 189    begin
 190       --  It cannot be assumed that the caller of this routine has a ATSD;
 191       --  so neither this procedure nor the procedures that it calls should
 192       --  raise or handle exceptions, or make use of a secondary stack.
 193
 194       --  This routine is only necessary because taskVarAdd cannot be
 195       --  executed once an VxWorks 653 partition has entered normal mode
 196       --  (depending on configRecord.c, allocation could be disabled).
 197       --  Otherwise, everything could have been done in Thread_Body_Enter.
 198
 199       if taskIdVerify (T) = ERROR then
 200          return ERROR;
 201       end if;
 202
 203       Result := taskVarAdd (T, Current_ATSD'Address);
 204       pragma Assert (Result /= ERROR);
 205
 206       --  The same issue applies to the task variable that contains the stack
 207       --  limit when that overflow checking mechanism is used instead of
 208       --  probing. If stack checking is enabled and limit checking is used,
 209       --  allocate the limit for this task. The environment task has this
 210       --  initialized by the binder-generated main when
 211       --  System.Stack_Check_Limits = True.
 212
 213       pragma Warnings (Off);
 214       --  OS is a constant
 215       if Result /= ERROR
 216         and then OS /= VxWorks_653
 217         and then Set_Stack_Limit_Hook /= null
 218       then
 219          Result := taskVarAdd (T, Stack_Limit'Address);
 220          pragma Assert (Result /= ERROR);
 221       end if;
 222       pragma Warnings (On);
 223
 224       return Result;
 225    end Register;
 226
 227    -------------------
 228    -- Set_Sec_Stack --
 229    -------------------
 230
 231    procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is
 232       CTSD : constant ATSD_Access := From_Address (Current_ATSD);
 233    begin
 234       pragma Assert (CTSD /= null);
 235       CTSD.Sec_Stack_Ptr := Stack;
 236    end Set_Sec_Stack;
 237
 238 begin
 239    --  Initialize run-time library
 240
 241    Init_RTS;
 242 end System.Threads;