diff options
Diffstat (limited to 'gcc/ada/i-vthrea.adb')
| -rw-r--r-- | gcc/ada/i-vthrea.adb | 386 |
1 files changed, 0 insertions, 386 deletions
diff --git a/gcc/ada/i-vthrea.adb b/gcc/ada/i-vthrea.adb deleted file mode 100644 index 049e1c4..0000000 --- a/gcc/ada/i-vthrea.adb +++ /dev/null @@ -1,386 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |