------------------------------------------------------------------------------ -- -- -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . T A S K _ P R I M I T I V E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1991,1992,1993,1994,1996 Florida State University -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU Library General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. GNARL is distributed in the hope that it will be use- -- -- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- -- eral Library Public License for more details. You should have received -- -- a copy of the GNU Library General Public License along with GNARL; see -- -- file COPYING.LIB. If not, write to the Free Software Foundation, 675 -- -- Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with GNAT.IO; with Interfaces.C.POSIX_timers; with Interfaces.C.POSIX_Error; use Interfaces.C.POSIX_Error; with Interfaces.C.POSIX_RTE; use Interfaces.C.POSIX_RTE; with Interfaces.C.Pthreads; use Interfaces.C.Pthreads; with Interfaces.C; use Interfaces.C; with System.Tasking; use System.Tasking; with System.Storage_Elements; use System.Storage_Elements; with System.Compiler_Exceptions; use System.Compiler_Exceptions; with System.Task_Specific_Data; use System.Task_Specific_Data; with System.Secondary_Stack; use System.Secondary_Stack; with System.Tasking_Soft_Links; with System.Task_Clock; use System.Task_Clock; with Unchecked_Conversion; with Interfaces.C.System_Constants; package body System.Task_Primitives is use Interfaces.C.Pthreads; use Interfaces.C.System_Constants; package RTE renames Interfaces.C.POSIX_RTE; package TSL renames System.Tasking_Soft_Links; Test_And_Set_Mutex : Lock; Abort_Signal : constant := 6; Abort_Handler : Abort_Handler_Pointer; ATCB_Key : aliased pthread_key_t; Unblocked_Signal_Mask : aliased RTE.Signal_Set; -- The set of signals that should be unblocked in a task. -- This is in general the signals that can be generated synchronously, -- and which should therefore be converted into Ada exceptions. -- It also includes the Abort_Signal, to allow asynchronous abortion. function To_void_ptr is new Unchecked_Conversion (TCB_Ptr, void_ptr); function To_TCB_Ptr is new Unchecked_Conversion (void_ptr, TCB_Ptr); function pthread_mutexattr_setprotocol (attr : access pthread_attr_t; priority : integer) return int; pragma Import (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol", "pthread_mutexattr_setprotocol"); function pthread_mutexattr_setprio_ceiling (attr : access pthread_attr_t; priority : int) return int; pragma Import (C, pthread_mutexattr_setprio_ceiling, "pthread_mutexattr_setprio_ceiling", "pthread_mutexattr_setprio_ceiling"); pthread_mutexattr_default : pthread_mutexattr_t; pragma Import (C, pthread_mutexattr_default, "pthread_mutexattr_default", "pthread_mutexattr_default"); ----------------------- -- Local Subprograms -- ----------------------- procedure Abort_Wrapper (signo : Integer; info : RTE.siginfo_ptr; context : System.Address); -- This is a signal handler procedure which calls the user-specified -- abort handler procedure. procedure LL_Wrapper (T : TCB_Ptr); -- A wrapper procedure that is called from a new low-level task. -- It performs initializations for the new task and calls the -- user-specified startup procedure. ------------------------- -- Initialize_LL_Tasks -- ------------------------- procedure Initialize_LL_Tasks (T : TCB_Ptr) is Result : int; begin T.LL_Entry_Point := null; T.Thread := pthread_self; Result := pthread_key_create (ATCB_Key'Access, null); if Result = FUNC_ERR then raise Storage_Error; -- Insufficient resources. end if; T.Thread := pthread_self; Result := pthread_setspecific (ATCB_Key, To_void_ptr (T)); if Result = FUNC_ERR then GNAT.IO.Put_Line ("Get specific failed"); raise Storage_Error; -- Insufficient resources. end if; pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_setspecific"); end Initialize_LL_Tasks; ---------- -- Self -- ---------- function Self return TCB_Ptr is Temp : aliased void_ptr; Result : int; begin Result := pthread_getspecific (ATCB_Key, Temp'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_getspecific"); return To_TCB_Ptr (Temp); end Self; --------------------- -- Initialize_Lock -- --------------------- procedure Initialize_Lock (Prio : System.Any_Priority; L : in out Lock) is Attributes : aliased pthread_mutexattr_t; Result : int; MUTEX_NONRECURSIVE_NP : constant := 2; begin Result := pthread_mutexattr_init (Attributes'Access); if Result = FUNC_ERR then raise STORAGE_ERROR; -- should be ENOMEM end if; Result := pthread_mutexattr_setkind (Attributes'Access, MUTEX_NONRECURSIVE_NP); if Result = FUNC_ERR then raise STORAGE_ERROR; -- should be ENOMEM end if; Result := pthread_mutex_init (L.mutex'Access, Attributes); if Result = FUNC_ERR then Result := pthread_mutexattr_destroy (Attributes'Access); raise STORAGE_ERROR; -- should be ENOMEM ??? end if; Result := pthread_mutexattr_destroy (Attributes'Access); end Initialize_Lock; ------------------- -- Finalize_Lock -- ------------------- procedure Finalize_Lock (L : in out Lock) is Result : int; begin Result := pthread_mutex_destroy (L.mutex'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_mutex_destroy"); end Finalize_Lock; ---------------- -- Write_Lock -- ---------------- -- -- The current pthreads implementation does not check for Ceiling -- violations. -- procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is Result : int; begin Ceiling_Violation := False; Result := pthread_mutex_lock (L.mutex'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_lock"); end Write_Lock; --------------- -- Read_Lock -- --------------- procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean) renames Write_Lock; ------------ -- Unlock -- ------------ procedure Unlock (L : in out Lock) is Result : int; begin Result := pthread_mutex_unlock (L.mutex'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_unlock"); end Unlock; --------------------- -- Initialize_Cond -- --------------------- procedure Initialize_Cond (Cond : in out Condition_Variable) is Attributes : aliased Pthreads.pthread_condattr_t; Result : int; begin Result := pthread_condattr_init (Attributes'Access); if Result = FUNC_ERR then raise STORAGE_ERROR; -- should be ENOMEM ??? end if; -- Result := pthread_cond_init (Cond.CV'Access, Attributes'Access); Result := pthread_cond_init (Cond.CV'Access, Attributes); if Result = FUNC_ERR then raise STORAGE_ERROR; -- should be ENOMEM ??? end if; Result := pthread_condattr_destroy (Attributes'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_condattr_destroy"); end Initialize_Cond; ------------------- -- Finalize_Cond -- ------------------- procedure Finalize_Cond (Cond : in out Condition_Variable) is Result : int; begin Result := pthread_cond_destroy (Cond.CV'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_destroy"); end Finalize_Cond; --------------- -- Cond_Wait -- --------------- procedure Cond_Wait (Cond : in out Condition_Variable; L : in out Lock) is Result : int; begin Result := pthread_cond_wait (Cond.CV'Access, L.mutex'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_wait"); end Cond_Wait; --------------------- -- Cond_Timed_Wait -- --------------------- procedure Cond_Timed_Wait (Cond : in out Condition_Variable; L : in out Lock; Abs_Time : System.Task_Clock.Stimespec; Timed_Out : out Boolean) is Result : int; TV : aliased timespec; use POSIX_Error; begin Timed_Out := False; -- Assume success until we know otherwise TV.tv_sec := int (Interfaces.C.POSIX_timers.time_t (Task_Clock.Stimespec_Seconds (Abs_Time))); TV.tv_nsec := long (Interfaces.C.POSIX_timers.Nanoseconds (Task_Clock.Stimespec_NSeconds (Abs_Time))); Result := pthread_cond_timedwait (Cond.CV'Access, L.mutex'Access, TV'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_timedwait"); end Cond_Timed_Wait; ----------------- -- Cond_Signal -- ----------------- procedure Cond_Signal (Cond : in out Condition_Variable) is Result : int; begin Result := pthread_cond_signal (Cond.CV'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_signal"); end Cond_Signal; ------------------ -- Set_Priority -- ------------------ procedure Set_Priority (T : TCB_Ptr; Prio : System.Any_Priority) is Result : int; Thread : Pthreads.pthread_t renames T.Thread; begin Result := pthread_setprio (Thread, int (Prio)); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio"); end Set_Priority; ---------------------- -- Set_Own_Priority -- ---------------------- procedure Set_Own_Priority (Prio : System.Any_Priority) is begin null; -- ENOSYS Result := -- pthread_setprio (pthread_self, int (Prio)); -- pragma Assert -- (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio"); end Set_Own_Priority; ------------------ -- Get_Priority -- ------------------ function Get_Priority (T : TCB_Ptr) return System.Any_Priority is Priority : aliased int := 0; begin -- ENOSYS Result := pthread_getprio (T.Thread, Priority'Access); -- pragma Assert -- (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio"); return System.Priority (Priority); end Get_Priority; ----------------------- -- Get_Own_Priority -- ----------------------- function Get_Own_Priority return System.Any_Priority is Result : int; Priority : aliased int := 0; begin Result := pthread_getprio (pthread_self, Priority'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio"); return System.Priority (Priority); end Get_Own_Priority; -------------------- -- Create_LL_Task -- -------------------- procedure Create_LL_Task (Priority : System.Any_Priority; Stack_Size : Task_Storage_Size; Task_Info : System.Task_Info.Task_Info_Type; LL_Entry_Point : LL_Task_Procedure_Access; Arg : System.Address; T : TCB_Ptr) is use Pthreads; Attributes : aliased pthread_attr_t; Result : int; L_Priority : System.Any_Priority := Priority; function To_Start_Addr is new Unchecked_Conversion (System.Address, start_addr); begin T.LL_Entry_Point := LL_Entry_Point; T.LL_Arg := Arg; T.Stack_Size := Stack_Size; Result := pthread_attr_init (Attributes'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_init"); -- Result := pthread_attr_setdetachstate (Attributes'Access, 1); -- pragma Assert -- (Result /= FUNC_ERR, "GNULLI failure---pthread_setdetachstate"); Result := pthread_attr_setstacksize (Attributes'Access, size_t (Stack_Size)); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_setstacksize"); Result := pthread_attr_setinheritsched (Attributes'Access, PTHREAD_DEFAULT_SCHED); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched"); Result := pthread_attr_setsched (Attributes'Access, SCHED_FIFO); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched"); -- The following priority adjustment is a kludge to get around needing -- root privileges to run at higher than 18 for FIFO or 19 for OTHER. if (L_Priority > 18) then L_Priority := 18; elsif (L_Priority < 14) then L_Priority := 14; end if; Result := pthread_attr_setprio (Attributes'Access, int (L_Priority)); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_setprio"); Result := pthread_create (T.Thread'Access, Attributes, To_Start_Addr (LL_Wrapper'Address), T.all'Address); if Result = FUNC_ERR then GNAT.IO.Put_Line ("pthread create failed"); raise Storage_Error; end if; pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_create"); Result := pthread_attr_destroy (Attributes'Access); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_destroy"); end Create_LL_Task; ----------------- -- Exit_LL_Task -- ------------------ procedure Exit_LL_Task is begin pthread_exit (System.Null_Address); end Exit_LL_Task; ---------------- -- Abort_Task -- ---------------- procedure Abort_Task (T : TCB_Ptr) is Result : int; begin -- Result := pthread_kill (T.Thread); -- pragma Assert -- (Result /= FUNC_ERR, "GNULLI failure---pthread_kill"); null; end Abort_Task; ---------------- -- Test_Abort -- ---------------- -- This procedure does nothing. It is intended for systems without -- asynchronous abortion, where the runtime system would have to -- synchronously poll for pending abortions. This should be done -- at least at every synchronization point. procedure Test_Abort is begin null; end Test_Abort; --------------------------- -- Install_Abort_Handler -- --------------------------- procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is act : aliased RTE.struct_sigaction; old_act : aliased RTE.struct_sigaction; Result : POSIX_Error.Return_Code; SA_SIGINFO : constant := 64; use type POSIX_Error.Return_Code; begin Abort_Handler := Handler; act.sa_flags := SA_SIGINFO; act.sa_handler := Abort_Wrapper'Address; RTE.sigemptyset (act.sa_mask'Access, Result); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigemptyset"); RTE.sigaction (Abort_Signal, act'Access, old_act'Access, Result); pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigaction"); end Install_Abort_Handler; ------------------- -- Abort_Wrapper -- ------------------- -- This is the handler called by the OS when an abort signal is -- received; it in turn calls the handler installed by the client. -- This procedure serves to isolate the client from the -- implementation-specific calling conventions of asynchronous -- handlers. procedure Abort_Wrapper (signo : Integer; info : RTE.siginfo_ptr; context : System.Address) is function Address_To_Call_State is new Unchecked_Conversion (System.Address, Pre_Call_State); begin Abort_Handler (Address_To_Call_State (context)); end Abort_Wrapper; --------------------------- -- Install_Error_Handler -- --------------------------- procedure Install_Error_Handler (Handler : System.Address) is Temp : Address; use Pthreads; begin -- Set up the soft links to tasking services used in the absence of -- tasking. These replace tasking-free defaults. Temp := TSL.Get_Jmpbuf_Address.all; -- pthread_set_jumpbuf_address (Temp); Temp := TSL.Get_Sec_Stack_Addr.all; -- pthread_set_sec_stack_addr (Temp); -- TSL.Get_Jmpbuf_Address := pthread_get_jumpbuf_address'Access; -- TSL.Set_Jmpbuf_Address := pthread_set_jumpbuf_address'Access; -- TSL.Get_Gnat_Exception := pthread_get_exception'Access; -- TSL.Set_Gnat_Exception := pthread_set_exception'Access; end Install_Error_Handler; --------------- -- LL_Assert -- --------------- procedure LL_Assert (B : Boolean; M : String) is begin null; end LL_Assert; ---------------- -- LL_Wrapper -- ---------------- procedure LL_Wrapper (T : TCB_Ptr) is Result : POSIX_Error.Return_Code; Result1 : int; Exc_Stack : String (1 .. 256); Exc_Base : Address := Exc_Stack (Exc_Stack'Last)'Address + 1; Old_Set : aliased RTE.Signal_Set; begin Result1 := pthread_setspecific (ATCB_Key, T.all'Address); RTE.sigprocmask ( RTE.SIG_UNBLOCK, Unblocked_Signal_Mask'Access, Old_Set'Access, Result); pragma Assert ( Result /= Failure, "GNULLI failure---sigprocmask"); -- Note that the following call may not return! T.LL_Entry_Point (T.LL_Arg); end LL_Wrapper; -------------------------- -- Test and Set support -- -------------------------- procedure Initialize_TAS_Cell (Cell : out TAS_Cell) is begin Cell.Value := 0; end Initialize_TAS_Cell; procedure Finalize_TAS_Cell (Cell : in out TAS_Cell) is begin null; end Finalize_TAS_Cell; procedure Clear (Cell : in out TAS_Cell) is begin Cell.Value := 1; end Clear; procedure Test_And_Set (Cell : in out TAS_Cell; Result : out Boolean) is Error : Boolean; begin Write_Lock (Test_And_Set_Mutex, Error); if Cell.Value = 1 then Result := False; else Result := True; Cell.Value := 1; end if; Unlock (Test_And_Set_Mutex); end Test_And_Set; function Is_Set (Cell : in TAS_Cell) return Boolean is begin return Cell.Value = 1; end Is_Set; begin Initialize_Lock (System.Any_Priority'Last, Test_And_Set_Mutex); end System.Task_Primitives;