diff options
Diffstat (limited to 'lang/gnat/files/5ftaprop.adb')
| -rw-r--r-- | lang/gnat/files/5ftaprop.adb | 664 |
1 files changed, 397 insertions, 267 deletions
diff --git a/lang/gnat/files/5ftaprop.adb b/lang/gnat/files/5ftaprop.adb index 813c40530c4a..3c94fc5dc6bb 100644 --- a/lang/gnat/files/5ftaprop.adb +++ b/lang/gnat/files/5ftaprop.adb @@ -1,15 +1,14 @@ ------------------------------------------------------------------------------ -- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- -- -- -- B o d y -- --- (Version for new GNARL) -- -- -- --- $Revision: 1.1 $ -- +-- $Revision: 1.5 $ -- -- -- --- Copyright (C) 1991,1992,1993,1994,1995,1996 Florida State University -- +-- Copyright (C) 1997, Florida State University -- -- -- -- 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- -- @@ -36,15 +35,19 @@ ------------------------------------------------------------------------------ -- This is the FreeBSD PTHREADS version of this package. Contributed --- by Daniel M. Eischen (deischen@iworks.InterWorks.org). +-- by Daniel M. Eischen (eischen@vigrid.com). + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Tasking.Debug; +-- used for Known_Tasks with Interfaces.C; -- used for int -- size_t -with System.Error_Reporting; --- used for Shutdown - with System.Interrupt_Management; -- used for Keep_Unmasked -- Abort_Task_Interrupt @@ -65,18 +68,28 @@ with System.Tasking; -- used for Ada_Task_Control_Block -- Task_ID +with System.Tasking.Initialization; +-- used for Defer/Undefer_Abort + +with System.Task_Info; +-- used for Task_Image_Type + +with System.OS_Primitives; +-- used for Delay_Modes + with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; - use System.Error_Reporting; use System.OS_Interface; use System.Parameters; + use System.OS_Primitives; - pragma Linker_Options ("-lc_r"); + pragma Linker_Options ("-pthread"); ------------------ -- Local Data -- @@ -85,12 +98,23 @@ package body System.Task_Primitives.Operations is -- The followings are logically constants, but need to be initialized -- at run time. - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread + All_Tasks_L : aliased System.Task_Primitives.RTS_Lock; + -- See comments on locking rules in System.Locking_Rules (spec). + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. Unblocked_Signal_Mask : aliased sigset_t; -- The set of signals that should unblocked in all tasks + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + ----------------------- -- Local Subprograms -- ----------------------- @@ -104,6 +128,30 @@ package body System.Task_Primitives.Operations is function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + ------------------- -- Abort_Handler -- ------------------- @@ -113,7 +161,7 @@ package body System.Task_Primitives.Operations is -- The technical issues and alternatives here are essentially -- the same as for raising exceptions in response to other - -- signals (e.g. Storage_Error). See code and comments in + -- signals (e.g. Storage_Error). See code and comments in -- the package body System.Interrupt_Management. -- Some implementations may not allow an exception to be propagated @@ -124,7 +172,7 @@ package body System.Task_Primitives.Operations is -- GNAT exceptions are originally implemented using setjmp()/longjmp(). -- On most UNIX systems, this will allow transfer out of a signal handler, -- which is usually the only mechanism available for implementing - -- asynchronous handlers of this kind. However, some + -- asynchronous handlers of this kind. However, some -- systems do not restore the signal mask on longjmp(), leaving the -- abort signal masked. @@ -135,12 +183,15 @@ package body System.Task_Primitives.Operations is -- Normal return from this handler will then raise -- the exception after the mask and other system state has -- been restored (see example below). + -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions. + -- 3. Unmask the signal in the Abortion_Signal exception handler -- (in the RTS). -- The following procedure would be needed if we can't lonjmp out of - -- a signal handler. (See below.) + -- a signal handler (See below) + -- procedure Raise_Abort_Signal is -- begin -- raise Standard'Abort_Signal; @@ -151,7 +202,7 @@ package body System.Task_Primitives.Operations is code : Interfaces.C.int; context : access struct_sigcontext) is - T : Task_ID := Self; + T : Task_ID := Self; Result : Interfaces.C.int; Old_Set : aliased sigset_t; @@ -160,14 +211,17 @@ package body System.Task_Primitives.Operations is -- following code can be used: if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level then + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask - (SIG_UNBLOCK, Unblocked_Signal_Mask'Access, Old_Set'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Enter_Task (pthread_sigmask)")); + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + raise Standard'Abort_Signal; end if; @@ -182,19 +236,39 @@ package body System.Task_Primitives.Operations is end Abort_Handler; + ------------------- + -- Stack_Guard -- + ------------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + + Stack_Base : constant Address := Get_Stack_Base (T.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + if On then + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); + else + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); + end if; + + pragma Assert (Res = 0); + end if; + end Stack_Guard; + ---------- -- Self -- ---------- - function Self return Task_ID is - Result : System.Address; - - begin - Result := pthread_getspecific (ATCB_Key); - pragma Assert (Result /= System.Null_Address - or else Shutdown ("GNULLI failure---pthread_getspecific")); - return To_Task_ID (Result); - end Self; + function Self return Task_ID renames Specific.Self; --------------------- -- Initialize_Lock -- @@ -215,8 +289,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutexattr_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then raise STORAGE_ERROR; @@ -224,23 +297,23 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutex_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then raise STORAGE_ERROR; end if; + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end Initialize_Lock; - procedure Initialize_Lock (L : access RTS_Lock) is + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutexattr_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then raise STORAGE_ERROR; @@ -248,13 +321,14 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutex_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then raise STORAGE_ERROR; end if; + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end Initialize_Lock; ------------------- @@ -266,8 +340,7 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_destroy")); + pragma Assert (Result = 0); end Finalize_Lock; procedure Finalize_Lock (L : access RTS_Lock) is @@ -275,8 +348,7 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_destroy")); + pragma Assert (Result = 0); end Finalize_Lock; ---------------- @@ -288,14 +360,11 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_lock (L); - if Result = 0 then - Ceiling_Violation := False; - else - Ceiling_Violation := Result = EINVAL; - end if; - -- assumes the cause of EINVAL is a priority ceiling violation - pragma Assert (Result = 0 or else Result = EINVAL - or else Shutdown ("GNULLI failure---pthread_mutex_lock")); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; procedure Write_Lock (L : access RTS_Lock) is @@ -303,17 +372,14 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_lock (L); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_lock")); + pragma Assert (Result = 0); end Write_Lock; procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - + Result : Interfaces.C.int; begin Result := pthread_mutex_lock (T.LL.L'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_lock")); + pragma Assert (Result = 0); end Write_Lock; --------------- @@ -334,8 +400,7 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_unlock")); + pragma Assert (Result = 0); end Unlock; procedure Unlock (L : access RTS_Lock) is @@ -343,158 +408,180 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_unlock")); + pragma Assert (Result = 0); end Unlock; procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - + Result : Interfaces.C.int; begin Result := pthread_mutex_unlock (T.LL.L'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_unlock")); + pragma Assert (Result = 0); end Unlock; ------------- -- Sleep -- ------------- - procedure Sleep (Self_ID : Task_ID) is + procedure Sleep (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) is + Result : Interfaces.C.int; begin - pragma Assert (Self_ID = Self - or else Shutdown ("GNULLI failure---Self in Sleep")); + pragma Assert (Self_ID = Self); Result := pthread_cond_wait (Self_ID.LL.CV'Access, Self_ID.LL.L'Access); + -- EINTR is not considered a failure. - pragma Assert (Result = 0 or else Result = EINTR - or else Shutdown ("GNULLI failure---Sleep")); + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; - --------------- - -- Sleep_For -- - --------------- + ----------------- + -- Timed_Sleep -- + ----------------- - procedure Sleep_For + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep (Self_ID : Task_ID; - Rel_Time : Duration; - Timedout : out Boolean) + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) is + + Check_Time : constant Duration := Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + begin - Sleep_Until (Self_ID, Rel_Time + Clock, Timedout); - end Sleep_For; + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Time; + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + Result := pthread_cond_timedwait + (Self_ID.LL.CV'Access, Self_ID.LL.L'Access, Request'Access); + + exit when Abs_Time <= Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; ----------------- - -- Sleep_Until -- + -- Timed_Delay -- ----------------- - procedure Sleep_Until + -- This is for use in implementing delay statements, so + -- we assume the caller is abort-deferred but is holding + -- no locks. + + procedure Timed_Delay (Self_ID : Task_ID; - Abs_Time : Duration; - Timedout : out Boolean) + Time : Duration; + Mode : ST.Delay_Modes) is - Request : aliased timespec; - Result : Interfaces.C.int; + Check_Time : constant Duration := Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; begin - pragma Assert (Self_ID = Self - or else Shutdown ("GNULLI failure---Self in Sleep_Until")); - if Abs_Time <= Clock then - Timedout := True; - Result := sched_yield; - return; - end if; + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( - Request := To_Timespec (Abs_Time); + Initialization.Defer_Abort_Nestable (Self_ID); + Write_Lock (Self_ID); - -- We loop until the requested delay is serviced. For early wakeups, - -- we check the Clock again and re-request delays until we sleep - -- at least for the specified amount. + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Time; + end if; - loop - -- Perform delays until one of the following conditions is true: - -- 1) cond_timedwait wakes up due to time expiration. - -- 2) We were interrupted by an abort signal (abortion is pending). - -- 3) We received a wakeup, via cond_signal to our CV. - -- 4) An error has occurred in the OS-provided delay primitive. - -- Conditions (1), (2), and (3) are normal. - -- Condition (4) should never happen unless the OS is broken, - -- or there is an error in our own runtime system code. + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.State := Delay_Sleep; loop - Result := pthread_cond_timedwait - (Self_ID.LL.CV'Access, Self_ID.LL.L'Access, Request'Access); - - if Result = 0 or else - (Self_ID.Pending_Action and then - Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level) - then - Timedout := False; - return; - else - -- As of 11/25/97, FreeBSD-3.0 returns the correct - -- (POSIX specified) code (ETIMEDOUT) for a timed-out - -- operation. Previous versions of FreeBSD would - -- return -1, and set the thread-safe errno to EAGAIN. - if Result < 0 and then Errno = EAGAIN then - Result := ETIMEDOUT; - end if; + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Base_Priority); end if; - if Result = ETIMEDOUT then - exit; - end if; + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - pragma Assert (Result /= EINVAL or else - Shutdown ("GNULLI failure---Sleep_Until (cond_timedwait)")); + Result := pthread_cond_timedwait + (Self_ID.LL.CV'Access, Self_ID.LL.L'Access, Request'Access); + exit when Abs_Time <= Clock; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); end loop; - -- Make sure we delayed long enough. If we did, give up the - -- CPU. Otherwise, request a delay again with unserviced amount - -- of time. + Self_ID.State := Runnable; + end if; - if (Abs_Time <= Clock) then - Timedout := True; - Result := sched_yield; - exit; - else - Request := To_Timespec (Abs_Time); - end if; - end loop; - end Sleep_Until; + Unlock (Self_ID); + Result := sched_yield; + Initialization.Undefer_Abort_Nestable (Self_ID); + end Timed_Delay; ----------- -- Clock -- ----------- function Clock return Duration is - TS : aliased timespec; + TV : aliased struct_timeval; Result : Interfaces.C.int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---clock_gettime")); - return To_Duration (TS); - exception - when others => - pragma Assert (Shutdown ("exception in Clock")); - return 0.0; + -- We should use clock_gettime() for FreeBSD 3.x; FreeBSD 2.x + -- doesn't have clock_gettime. + Result := gettimeofday (TV'Unchecked_Access, System.Null_Address); + pragma Assert (Result = 0); + return To_Duration (TV); end Clock; ------------ -- Wakeup -- ------------ - procedure Wakeup (T : Task_ID) is + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.LL.CV'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Wakeup")); + pragma Assert (Result = 0); end Wakeup; ----------- @@ -503,6 +590,7 @@ package body System.Task_Primitives.Operations is procedure Yield is Result : Interfaces.C.int; + begin Result := sched_yield; end Yield; @@ -511,31 +599,27 @@ package body System.Task_Primitives.Operations is -- Set_Priority -- ------------------ - -- FreeBSD doesn't have the correct pthread_setschedparam routine - -- yet. Instead, pthread_setschedparam is imported from pthread_setprio - -- which only takes a pthread_t and integer as arguments. --- procedure Set_Priority (T : Task_ID; Prio : System.Any_Priority) is --- Result : Interfaces.C.int; --- Param : aliased struct_sched_param; --- begin --- T.LL.Current_Priority := Interfaces.C.int (Prio); --- Param.prio := Interfaces.C.int (Prio); --- --- Result := pthread_setschedparam (T.LL.Thread, SCHED_FIFO, --- Param'Access); --- pragma Assert (Result = 0 --- or else Shutdown ("GNULLI failure---Set_Priority")); --- --- end Set_Priority; procedure Set_Priority (T : Task_ID; Prio : System.Any_Priority) is Result : Interfaces.C.int; + Param : aliased struct_sched_param; + begin T.LL.Current_Priority := Interfaces.C.int (Prio); - Result := pthread_setschedparam (T.LL.Thread, Interfaces.C.int (Prio)); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Set_Priority")); + -- Convert the Ada priority to be based around the default + -- system priority. + Param.sched_priority := DEFAULT_PRIO + Interfaces.C.int (Prio) - + Interfaces.C.int (System.Default_Priority); + + if Time_Slice_Supported and then Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.LL.Thread, SCHED_RR, Param'Access); + else + Result := pthread_setschedparam + (T.LL.Thread, SCHED_FIFO, Param'Access); + end if; + pragma Assert (Result = 0); end Set_Priority; ------------------ @@ -552,15 +636,22 @@ package body System.Task_Primitives.Operations is ---------------- procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; - begin - Self_ID.LL.Thread := pthread_self; - Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID)); - pragma Assert (Result = 0 or else - Shutdown ("GNULLI failure---Enter_Task (pthread_setspecific)")); + Specific.Set (Self_ID); + + Lock_All_Tasks_List; + + for I in Known_Tasks'Range loop + if Known_Tasks (I) = null then + Known_Tasks (I) := Self_ID; + Self_ID.Known_Tasks_Index := I; + exit; + end if; + end loop; + + Unlock_All_Tasks_List; end Enter_Task; ---------------------- @@ -573,9 +664,14 @@ package body System.Task_Primitives.Operations is Cond_Attr : aliased pthread_condattr_t; begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutexattr_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then Succeeded := False; @@ -583,8 +679,7 @@ package body System.Task_Primitives.Operations is end if; Result := pthread_mutex_init (Self_ID.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_mutex_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then Succeeded := False; @@ -592,29 +687,30 @@ package body System.Task_Primitives.Operations is end if; Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_condattr_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then Result := pthread_mutex_destroy (Self_ID.LL.L'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_destory")); + pragma Assert (Result = 0); Succeeded := False; return; end if; Result := pthread_cond_init (Self_ID.LL.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_cond_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then Result := pthread_mutex_destroy (Self_ID.LL.L'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_mutex_destory")); + pragma Assert (Result = 0); + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); Succeeded := False; return; end if; + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + Succeeded := True; end Initialize_TCB; @@ -630,6 +726,8 @@ package body System.Task_Primitives.Operations is Priority : System.Any_Priority; Succeeded : out Boolean) is + use type System.Task_Info.Task_Image_Type; + Attributes : aliased pthread_attr_t; Adjusted_Stack_Size : Interfaces.C.size_t; Result : Interfaces.C.int; @@ -638,62 +736,41 @@ package body System.Task_Primitives.Operations is Unchecked_Conversion (System.Address, Thread_Body); begin - if Stack_Size = System.Parameters.Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (2 * Default_Stack_Size); - -- Let's change the s-parame.adb to give a larger Stack_Size ????? - else - if Stack_Size < Size_Type (Minimum_Stack_Size) then - Adjusted_Stack_Size := - Interfaces.C.size_t (Stack_Size + Minimum_Stack_Size); - - -- sum, instead of max: may be overkill, but should be safe - -- thr_min_stack is a function call. - - -- Actually, we want to get the Default_Stack_Size and - -- Minimum_Stack_Size from the file System.Parameters. - -- Right now the package is not made target specific. - -- We use our own local definitions for now ??? - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - -- Ask for 4 extra bytes of stack space so that the ATCB - -- pointer can be stored below the stack limit, plus extra - -- space for the frame of Task_Wrapper. This is so the user - -- gets the amount of stack requested exclusive of the needs - -- of the runtime. + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); end if; - Adjusted_Stack_Size := Adjusted_Stack_Size + 4; + if Stack_Base_Available then + -- If Stack Checking is supported then allocate 2 additional pages: + -- + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. - -- Since the initial signal mask of a thread is inherited from the - -- creator, we need to set our local signal mask mask all signals - -- during the creation operation, to make sure the new thread is - -- not disturbed by signals before it has set its own Task_ID. + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; + end if; Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM - or else Shutdown ("GNULLI failure---pthread_attr_init")); + pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then Succeeded := False; return; end if; - -- Create threads detached following email to report@gnat.com - -- confirming this is correct (should be fixed for GNAT after 3.09). - -- (Peter Burwood) Result := pthread_attr_setdetachstate (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_setdetachstate")); + pragma Assert (Result = 0); Result := pthread_attr_setstacksize (Attributes'Access, Interfaces.C.size_t (Adjusted_Stack_Size)); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---pthread_attr_setstacksize")); + pragma Assert (Result = 0); -- Since the initial signal mask of a thread is inherited from the -- creator, and the Environment task has all its signals masked, we @@ -705,13 +782,20 @@ package body System.Task_Primitives.Operations is Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN - or else Shutdown ("GNULLI failure---Create_Task (pthread_create)")); + pragma Assert (Result = 0 or else Result = EAGAIN); Succeeded := Result = 0; - Set_Priority (T, Priority); + if T.Task_Image /= null then + declare + Name : aliased string (1 .. T.Task_Image.all'Length + 1); + begin + Name := T.Task_Image.all & Ascii.Nul; + Result := pthread_set_name_np (T.LL.Thread, Name'Address); + end; + end if; + Set_Priority (T, Priority); end Create_Task; ------------------ @@ -722,21 +806,20 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; Tmp : Task_ID := T; - procedure Free is new Unchecked_Deallocation - (Ada_Task_Control_Block, Task_ID); + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); begin Result := pthread_mutex_destroy (T.LL.L'Access); - pragma Assert (Result = 0 or else - Shutdown ("GNULLI failure---Finalize_TCB (pthread_mutex_destroy)")); + pragma Assert (Result = 0); + Result := pthread_cond_destroy (T.LL.CV'Access); - pragma Assert (Result = 0 or else - Shutdown ("GNULLI failure---Finalize_TCB (pthread_cond_destroy)")); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; - -- Following report to report@gnat.com regarding ATCB memory leak - -- this Free is now called. The answer back from ACT didn't give - -- the source for a fix, but I calling this Free is sufficient. - -- (Peter Burwood) Free (Tmp); end Finalize_TCB; @@ -759,21 +842,76 @@ package body System.Task_Primitives.Operations is begin Result := pthread_kill (T.LL.Thread, Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Abort_Task")); + pragma Assert (Result = 0); end Abort_Task; ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + ------------------------- + -- Lock_All_Tasks_List -- + ------------------------- + + procedure Lock_All_Tasks_List is + begin + Write_Lock (All_Tasks_L'Access); + end Lock_All_Tasks_List; + + --------------------------- + -- Unlock_All_Tasks_List -- + --------------------------- + + procedure Unlock_All_Tasks_List is + begin + Unlock (All_Tasks_L'Access); + end Unlock_All_Tasks_List; + + ---------------- -- Initialize -- ---------------- procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + param : aliased struct_sched_param; begin + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level); + + Specific.Initialize (Environment_Task); Enter_Task (Environment_Task); @@ -783,33 +921,31 @@ package body System.Task_Primitives.Operations is act.sa_handler := Abort_Handler'Address; Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Initialize (sigemptyset)")); + pragma Assert (Result = 0); act.sa_mask := Tmp_Set; Result := sigaction ( Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Access, + act'Unchecked_Access, old_act'Unchecked_Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Initialize (sigaction)")); + + pragma Assert (Result = 0); + + if Time_Slice_Supported and then Time_Slice_Val > 0 then + if sched_getparam (Self_PID, param'Access) = 0 then + Result := sched_setscheduler (Self_PID, SCHED_RR, param'Access); + pragma Assert (Result = 0); + end if; + end if; end Initialize; begin declare Result : Interfaces.C.int; - begin - -- pthread_init; - -- This call is needed for MIT thread library. We wish - -- we could move this to s-osinte.adb and be executed during - -- the package elaboration. However, in doing so we get an - -- elaboration problem. - - -- It doesn't appear necessary to call it because pthread_init is - -- called before any Ada elaboration occurs. + begin -- Mask Environment task for all signals. The original mask of the -- Environment task will be recovered by Interrupt_Server task @@ -821,20 +957,14 @@ begin -- Prepare the set of signals that should unblocked in all tasks Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Initialize (sigemptyset)")); + pragma Assert (Result = 0); for J in Interrupt_Management.Interrupt_ID loop if System.Interrupt_Management.Keep_Unmasked (J) then Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Initialize (sigaddset)")); + pragma Assert (Result = 0); end if; end loop; - - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0 - or else Shutdown ("GNULLI failure---Initialize (pthread_keycreate)")); end; end System.Task_Primitives.Operations; |