diff options
Diffstat (limited to 'gcc/ada/s-taprop-linux.adb')
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 163 |
1 files changed, 43 insertions, 120 deletions
diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index d255d7cebea..6cb7eb7e5cb 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -40,44 +40,32 @@ 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.Parameters; +-- used for Size_Type + +with System.Tasking.Debug; +-- used for Known_Tasks + with System.Interrupt_Management; -- used for Keep_Unmasked -- Abort_Task_Interrupt -- Interrupt_ID -with System.Parameters; --- used for Size_Type +with System.OS_Primitives; +-- used for Delay_Modes -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_Id +with System.Soft_Links; +-- used for Abort_Defer/Undefer with Ada.Exceptions; -- used for Raise_Exception -- Raise_From_Signal_Handler -- Exception_Id -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Stages. - -with System.OS_Primitives; --- used for Delay_Modes - -with System.Soft_Links; --- used for Abort_Defer/Undefer - with Unchecked_Conversion; with Unchecked_Deallocation; @@ -90,8 +78,6 @@ package body System.Task_Primitives.Operations is use System.Parameters; use System.OS_Primitives; - package SSL renames System.Soft_Links; - ---------------- -- Local Data -- ---------------- @@ -111,12 +97,10 @@ package body System.Task_Primitives.Operations is -- 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 + -- The set of signals that should be unblocked in all tasks -- The followings are internal configuration constants needed - Priority_Ceiling_Emulation : constant Boolean := True; - Next_Serial_Number : Task_Serial_Number := 100; -- We start at 100, to reserve some special values for -- using in error checking. @@ -127,9 +111,6 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set - -- The following are effectively constants, but they need to -- be initialized by calling a pthread_ function. @@ -280,14 +261,11 @@ package body System.Task_Primitives.Operations is (Prio : System.Any_Priority; L : access Lock) is - Result : Interfaces.C.int; + pragma Unreferenced (Prio); + Result : Interfaces.C.int; begin - if Priority_Ceiling_Emulation then - L.Ceiling := Prio; - end if; - - Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access); + Result := pthread_mutex_init (L, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -319,7 +297,7 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : access Lock) is Result : Interfaces.C.int; begin - Result := pthread_mutex_destroy (L.L'Access); + Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); end Finalize_Lock; @@ -336,37 +314,13 @@ package body System.Task_Primitives.Operations is procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - begin - if Priority_Ceiling_Emulation then - declare - Self_ID : constant Task_Id := Self; - - begin - if Self_ID.Common.LL.Active_Priority > L.Ceiling then - Ceiling_Violation := True; - return; - end if; - - L.Saved_Priority := Self_ID.Common.LL.Active_Priority; + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = EINVAL; - if Self_ID.Common.LL.Active_Priority < L.Ceiling then - Self_ID.Common.LL.Active_Priority := L.Ceiling; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - end; - - else - Result := pthread_mutex_lock (L.L'Access); - Ceiling_Violation := Result = EINVAL; - - -- Assume the cause of EINVAL is a priority ceiling violation + -- Assume the cause of EINVAL is a priority ceiling violation - pragma Assert (Result = 0 or else Result = EINVAL); - end if; + pragma Assert (Result = 0 or else Result = EINVAL); end Write_Lock; procedure Write_Lock @@ -405,25 +359,9 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : access Lock) is Result : Interfaces.C.int; - begin - if Priority_Ceiling_Emulation then - declare - Self_ID : constant Task_Id := Self; - - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - - if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then - Self_ID.Common.LL.Active_Priority := L.Saved_Priority; - end if; - end; - - else - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end if; + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); end Unlock; procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is @@ -553,14 +491,8 @@ package body System.Task_Primitives.Operations is Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; - begin - - -- 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! :( - - SSL.Abort_Defer.all; + begin if Single_Lock then Lock_RTS; end if; @@ -611,7 +543,6 @@ package body System.Task_Primitives.Operations is end if; Result := sched_yield; - SSL.Abort_Undefer.all; end Timed_Delay; --------------------- @@ -678,12 +609,6 @@ package body System.Task_Primitives.Operations is begin T.Common.Current_Priority := Prio; - if Priority_Ceiling_Emulation then - if T.Common.LL.Active_Priority < Prio then - T.Common.LL.Active_Priority := Prio; - end if; - end if; - -- Priorities are in range 1 .. 99 on GNU/Linux, so we map -- map 0 .. 31 to 1 .. 32 @@ -693,7 +618,7 @@ package body System.Task_Primitives.Operations is Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_RR, Param'Access); - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access); @@ -1167,6 +1092,26 @@ package body System.Task_Primitives.Operations is begin Environment_Task_Id := Environment_Task; + Interrupt_Management.Initialize; + + -- Prepare the set of signals that should be unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + 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); + end if; + end loop; + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); -- Initialize the global RTS lock @@ -1196,26 +1141,4 @@ package body System.Task_Primitives.Operations is end if; end Initialize; -begin - declare - Result : Interfaces.C.int; - begin - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - 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); - end if; - end loop; - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0); - end; end System.Task_Primitives.Operations; |