--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT 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/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks 653 version of this package
+
+pragma Restrictions (No_Tasking);
+-- The VxWorks 653 version of this package is intended only for programs
+-- which do not use Ada tasking. This restriction ensures that this
+-- will be checked by the binder.
+
+with System.OS_Versions; use System.OS_Versions;
+with System.Secondary_Stack;
+pragma Elaborate_All (System.Secondary_Stack);
+
+package body System.Threads is
+
+ use Interfaces.C;
+
+ package SSS renames System.Secondary_Stack;
+
+ package SSL renames System.Soft_Links;
+
+ Current_ATSD : aliased System.Address := System.Null_Address;
+ pragma Export (C, Current_ATSD, "__gnat_current_atsd");
+
+ Main_ATSD : aliased ATSD;
+ -- TSD for environment task
+
+ Stack_Limit : Address;
+
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit if
+ -- limit checking is used.
+
+ --------------------------
+ -- VxWorks specific API --
+ --------------------------
+
+ ERROR : constant STATUS := Interfaces.C.int (-1);
+
+ function taskIdVerify (tid : t_id) return STATUS;
+ pragma Import (C, taskIdVerify, "taskIdVerify");
+
+ function taskIdSelf return t_id;
+ pragma Import (C, taskIdSelf, "taskIdSelf");
+
+ function taskVarAdd
+ (tid : t_id; pVar : System.Address) return int;
+ pragma Import (C, taskVarAdd, "taskVarAdd");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Init_RTS;
+ -- This procedure performs the initialization of the run-time lib.
+ -- It installs System.Threads versions of certain operations of the
+ -- run-time lib.
+
+ procedure Install_Handler;
+ pragma Import (C, Install_Handler, "__gnat_install_handler");
+
+ function Get_Sec_Stack_Addr return Address;
+
+ procedure Set_Sec_Stack_Addr (Addr : Address);
+
+ -----------------------
+ -- Thread_Body_Enter --
+ -----------------------
+
+ procedure Thread_Body_Enter
+ (Sec_Stack_Address : System.Address;
+ Sec_Stack_Size : Natural;
+ Process_ATSD_Address : System.Address)
+ is
+ -- Current_ATSD must already be a taskVar of taskIdSelf.
+ -- No assertion because taskVarGet is not available on VxWorks/CERT,
+ -- which is used on VxWorks 653 3.x as a guest OS.
+
+ TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
+
+ begin
+
+ TSD.Sec_Stack_Addr := Sec_Stack_Address;
+ SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
+ Current_ATSD := Process_ATSD_Address;
+
+ Install_Handler;
+
+ -- Initialize stack limit if needed
+
+ if Current_ATSD /= Main_ATSD'Address
+ and then Set_Stack_Limit_Hook /= null
+ then
+ Set_Stack_Limit_Hook.all;
+ end if;
+ end Thread_Body_Enter;
+
+ ----------------------------------
+ -- Thread_Body_Exceptional_Exit --
+ ----------------------------------
+
+ procedure Thread_Body_Exceptional_Exit
+ (EO : Ada.Exceptions.Exception_Occurrence)
+ is
+ pragma Unreferenced (EO);
+
+ begin
+ -- No action for this target
+
+ null;
+ end Thread_Body_Exceptional_Exit;
+
+ -----------------------
+ -- Thread_Body_Leave --
+ -----------------------
+
+ procedure Thread_Body_Leave is
+ begin
+ -- No action for this target
+
+ null;
+ end Thread_Body_Leave;
+
+ --------------
+ -- Init_RTS --
+ --------------
+
+ procedure Init_RTS is
+ -- Register environment task
+ Result : constant Interfaces.C.int := Register (taskIdSelf);
+ pragma Assert (Result /= ERROR);
+
+ begin
+ Main_ATSD.Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT;
+ Current_ATSD := Main_ATSD'Address;
+ Install_Handler;
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ end Init_RTS;
+
+ ------------------------
+ -- Get_Sec_Stack_Addr --
+ ------------------------
+
+ function Get_Sec_Stack_Addr return Address is
+ CTSD : constant ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (CTSD /= null);
+ return CTSD.Sec_Stack_Addr;
+ end Get_Sec_Stack_Addr;
+
+ --------------
+ -- Register --
+ --------------
+
+ function Register (T : Thread_Id) return STATUS is
+ Result : STATUS;
+
+ begin
+ -- It cannot be assumed that the caller of this routine has a ATSD;
+ -- so neither this procedure nor the procedures that it calls should
+ -- raise or handle exceptions, or make use of a secondary stack.
+
+ -- This routine is only necessary because taskVarAdd cannot be
+ -- executed once an VxWorks 653 partition has entered normal mode
+ -- (depending on configRecord.c, allocation could be disabled).
+ -- Otherwise, everything could have been done in Thread_Body_Enter.
+
+ if taskIdVerify (T) = ERROR then
+ return ERROR;
+ end if;
+
+ Result := taskVarAdd (T, Current_ATSD'Address);
+ pragma Assert (Result /= ERROR);
+
+ -- The same issue applies to the task variable that contains the stack
+ -- limit when that overflow checking mechanism is used instead of
+ -- probing. If stack checking is enabled and limit checking is used,
+ -- allocate the limit for this task. The environment task has this
+ -- initialized by the binder-generated main when
+ -- System.Stack_Check_Limits = True.
+
+ pragma Warnings (Off);
+ -- OS is a constant
+ if Result /= ERROR
+ and then OS /= VxWorks_653
+ and then Set_Stack_Limit_Hook /= null
+ then
+ Result := taskVarAdd (T, Stack_Limit'Address);
+ pragma Assert (Result /= ERROR);
+ end if;
+ pragma Warnings (On);
+
+ return Result;
+ end Register;
+
+ ------------------------
+ -- Set_Sec_Stack_Addr --
+ ------------------------
+
+ procedure Set_Sec_Stack_Addr (Addr : Address) is
+ CTSD : constant ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (CTSD /= null);
+ CTSD.Sec_Stack_Addr := Addr;
+ end Set_Sec_Stack_Addr;
+
+begin
+ -- Initialize run-time library
+
+ Init_RTS;
+end System.Threads;
projects / gcc.git / commitdiff