diff options
Diffstat (limited to 'gcc/ada/libgnat/s__thread-ae653.adb')
| -rw-r--r-- | gcc/ada/libgnat/s__thread-ae653.adb | 247 |
1 files changed, 247 insertions, 0 deletions
diff --git a/gcc/ada/libgnat/s__thread-ae653.adb b/gcc/ada/libgnat/s__thread-ae653.adb new file mode 100644 index 0000000..ca87128 --- /dev/null +++ b/gcc/ada/libgnat/s__thread-ae653.adb @@ -0,0 +1,247 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |