diff options
Diffstat (limited to 'gcc/ada/i-vthrea.adb')
| -rw-r--r-- | gcc/ada/i-vthrea.adb | 386 |
1 files changed, 386 insertions, 0 deletions
diff --git a/gcc/ada/i-vthrea.adb b/gcc/ada/i-vthrea.adb new file mode 100644 index 00000000000..049e1c4bf68 --- /dev/null +++ b/gcc/ada/i-vthrea.adb @@ -0,0 +1,386 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V T H R E A D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 2, or (at your option) any later ver- -- +-- sion. GNARL 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Implement APEX process registration for AE653 + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.Secondary_Stack; +with System.Soft_Links; +with System.Task_Primitives.Ae_653; +with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; +with System.Tasking; use System.Tasking; +with System.Task_Info; +with System.Tasking.Initialization; + +package body Interfaces.Vthreads is + + use System.OS_Interface; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Enter_Task (T : Task_ID; Thread : Thread_Id); + -- Duplicate and generalize + -- System.Task_Primitives.Operations.Enter_Task + + procedure GNAT_Error_Handler (Sig : Signal); + -- Signal handler for ARINC processes + + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for PPC systems. + + procedure Install_Handler; + -- Install signal handlers for the calling ARINC process + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Duplicate and generalize + -- System.Task_Primitives.Operations.Register_Foreign_Thread + + ----------------------------- + -- Install_Signal_Handlers -- + ----------------------------- + + function Install_Signal_Handlers return Interfaces.C.int is + begin + Install_Handler; + Init_Float; + return 0; + end Install_Signal_Handlers; + + ---------------------- + -- Register_Foreign -- + ---------------------- + + -- Create Ada task data structures for an ARINC process. All dynamic + -- allocation of related data structures must be done via this routine. + + function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS is + use Interfaces.C; + use System.Task_Primitives.Ae_653; + + pragma Assert (taskVarGet (T, ATCB_Key_Addr) = ERROR); + -- "T" is not yet registered + + Result : OSI.STATUS := taskIdVerify (T); + Status : OSI.STATUS := OK; + Temp_Id : Task_ID; + + begin + if Result = OK then + Status := taskVarGet (T, ATCB_Key_Addr); + + -- Error of already registered + + if Status /= ERROR then + Result := ERROR; + + else + -- Create a TCB + + declare + -- Make sure the caller has a TCB, since it's possible to have + -- pure C APEX processes that create ones calling Ada code + + Caller : Task_ID; + + begin + Status := taskVarGet (taskIdSelf, ATCB_Key_Addr); + + if Status = ERROR then + Caller := Register_Foreign_Thread (taskIdSelf); + end if; + end; + + if taskIdSelf /= T then + Temp_Id := Register_Foreign_Thread (T); + end if; + + Result := OK; + end if; + end if; + + return Result; + end Register_Foreign; + + ------------------- + -- Reset_Foreign -- + ------------------- + + -- Reinitialize Ada task data structures. No dynamic allocation + -- may occur via this routine. + + function Reset_Foreign (T : Thread_Id) return STATUS is + use Interfaces.C; + use System.Secondary_Stack; + use System.Task_Primitives.Ae_653; + use type System.Address; + + pragma Assert (taskVarGet (T, ATCB_Key_Addr) /= ERROR); + -- "T" has already been registered + + Result : STATUS := taskVarGet (T, ATCB_Key_Addr); + function To_Address is new Ada.Unchecked_Conversion + (Interfaces.C.int, System.Address); + + pragma Assert ( + To_Task_Id + (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr + /= System.Null_Address); + -- "T" already has a secondary stack + + begin + if Result /= ERROR then + + -- Just reset the secondary stack pointer. The implementation here + -- assumes that the fixed secondary stack implementation is used. + -- If not, there will be a memory leak (along with allocation, which + -- is prohibited for ARINC processes once the system enters "normal" + -- mode). + + SS_Init + (To_Task_Id + (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr); + Result := OK; + end if; + + return Result; + end Reset_Foreign; + + ------------------ + -- Setup_Thread -- + ------------------ + + function Setup_Thread return System.Address is + Result : System.Address := System.Null_Address; + Status : OSI.STATUS; + + begin + if Is_Valid_Task then + Status := Reset_Foreign (taskIdSelf); + Result := + To_Address (System.Task_Primitives.Operations.Self); + else + Status := Register_Foreign (taskIdSelf); + Install_Handler; + Init_Float; + Result := + To_Address (System.Task_Primitives.Operations.Self); + end if; + + return Result; + end Setup_Thread; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (T : Task_ID; Thread : Thread_Id) is + use System.Task_Primitives.Ae_653; + + begin + Set_Task_Thread (T, Thread); + end Enter_Task; + + ------------------------ + -- GNAT_Error_Handler -- + ------------------------ + + procedure GNAT_Error_Handler (Sig : Signal) is + Mask : aliased sigset_t; + Result : int; + + begin + -- This code is the Ada replacement for init.c in the + -- AE653 level B runtime. + + -- VxWorks will always mask out the signal during the signal + -- handler and will reenable it on a longjmp. GNAT does not + -- generate a longjmp to return from a signal handler so the + -- signal will still be masked unless we unmask it. + + Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); + Result := sigdelset (Mask'Access, Sig); + Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); + + case Sig is + when SIGFPE => + Raise_Exception (Constraint_Error'Identity, "SIGFPE"); + when SIGILL => + Raise_Exception (Constraint_Error'Identity, "SIGILL"); + when SIGSEGV => + Raise_Exception + (Program_Error'Identity, + "erroneous memory access"); + when SIGBUS => + -- SIGBUS indicates stack overflow when it occurs + -- in an application domain (but not in the Core + -- OS under AE653, or in the kernel domain under + -- AE 1.1). + Raise_Exception + (Storage_Error'Identity, + "stack overflow or SIGBUS"); + when others => + Raise_Exception (Program_Error'Identity, "unhandled signal"); + end case; + end GNAT_Error_Handler; + + --------------------- + -- Install_Handler -- + --------------------- + + procedure Install_Handler is + Mask : aliased sigset_t; + Signal_Action : aliased struct_sigaction; + Result : Interfaces.C.int; + + begin + -- Set up signal handler to map synchronous signals to appropriate + -- exceptions. Make sure that the handler isn't interrupted by + -- another signal that might cause a scheduling event! + + -- This code is the Ada replacement for init.c in the + -- AE653 level B runtime. + Signal_Action.sa_handler := GNAT_Error_Handler'Address; + Signal_Action.sa_flags := SA_ONSTACK; + Result := sigemptyset (Mask'Access); + Signal_Action.sa_mask := Mask; + + Result := sigaction + (Signal (SIGFPE), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGILL), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null); + + Result := sigaction + (Signal (SIGBUS), Signal_Action'Unchecked_Access, null); + + end Install_Handler; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + Foreign_Task_Elaborated : aliased Boolean := True; + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is + pragma Assert (Thread = taskIdSelf or else Is_Valid_Task); + -- Ensure that allocation will work + + Local_ATCB : aliased Ada_Task_Control_Block (0); + New_Id : Task_ID; + Succeeded : Boolean; + + use type Interfaces.C.unsigned; + use type System.Address; + use System.Task_Info; + use System.Task_Primitives.Ae_653; + + begin + if taskIdSelf = Thread then + declare + Self : Task_ID := Local_ATCB'Unchecked_Access; + -- Temporarily record this as the Task_ID for the thread + + begin + Set_Current_Priority (Self, System.Priority'First); + Set_Task_Thread (Self, Thread); + end; + end if; + + pragma Assert (Is_Valid_Task); + -- It is now safe to use an allocator for the real TCB + + New_Id := new Ada_Task_Control_Block (0); + + -- Finish initialization + + System.Tasking.Initialize_ATCB + (New_Id, null, System.Null_Address, Null_Task, + Foreign_Task_Elaborated'Access, + System.Priority'First, + System.Task_Info.Unspecified_Task_Info, 0, New_Id, + Succeeded); + pragma Assert (Succeeded); + + New_Id.Master_of_Task := 0; + New_Id.Master_Within := New_Id.Master_of_Task + 1; + + for L in New_Id.Entry_Calls'Range loop + New_Id.Entry_Calls (L).Self := New_Id; + New_Id.Entry_Calls (L).Level := L; + end loop; + + New_Id.Common.State := Runnable; + New_Id.Awake_Count := 1; + + -- Since this is not an ordinary Ada task, we will start out undeferred + + New_Id.Deferral_Level := 0; + + System.Soft_Links.Create_TSD (New_Id.Common.Compiler_Data); + + -- Allocate a fixed secondary stack + + pragma Assert + (New_Id.Common.Compiler_Data.Sec_Stack_Addr = System.Null_Address); + System.Secondary_Stack.SS_Init + (New_Id.Common.Compiler_Data.Sec_Stack_Addr); + + Enter_Task (New_Id, Thread); + + return New_Id; + end Register_Foreign_Thread; + + -- Force use of tasking versions of secondary stack routines: + + procedure Force_Closure renames + System.Tasking.Initialization.Defer_Abortion; + pragma Unreferenced (Force_Closure); + +-- Package elaboration code + +begin + -- Register the exported routines with the vThreads ARINC API + + procCreateHookAdd (Register_Foreign'Access); + procStartHookAdd (Reset_Foreign'Access); +end Interfaces.Vthreads; |