| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S Y S T E M . T H R E A D S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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; |
| |
| package body System.Threads is |
| |
| use Interfaces.C; |
| |
| 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 return SST.SS_Stack_Ptr; |
| |
| procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr); |
| |
| ----------------------- |
| -- Thread_Body_Enter -- |
| ----------------------- |
| |
| procedure Thread_Body_Enter |
| (Sec_Stack_Ptr : SST.SS_Stack_Ptr; |
| 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_Ptr := Sec_Stack_Ptr; |
| SST.SS_Init (TSD.Sec_Stack_Ptr); |
| 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_Ptr := SSL.Get_Sec_Stack_NT; |
| Current_ATSD := Main_ATSD'Address; |
| Install_Handler; |
| SSL.Get_Sec_Stack := Get_Sec_Stack'Access; |
| SSL.Set_Sec_Stack := Set_Sec_Stack'Access; |
| end Init_RTS; |
| |
| ------------------- |
| -- Get_Sec_Stack -- |
| ------------------- |
| |
| function Get_Sec_Stack return SST.SS_Stack_Ptr is |
| CTSD : constant ATSD_Access := From_Address (Current_ATSD); |
| begin |
| pragma Assert (CTSD /= null); |
| return CTSD.Sec_Stack_Ptr; |
| end Get_Sec_Stack; |
| |
| -------------- |
| -- 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 -- |
| ------------------- |
| |
| procedure Set_Sec_Stack (Stack : SST.SS_Stack_Ptr) is |
| CTSD : constant ATSD_Access := From_Address (Current_ATSD); |
| begin |
| pragma Assert (CTSD /= null); |
| CTSD.Sec_Stack_Ptr := Stack; |
| end Set_Sec_Stack; |
| |
| begin |
| -- Initialize run-time library |
| |
| Init_RTS; |
| end System.Threads; |
