X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fs-taprop-irix.adb;h=8893c010571fefcb74059037a09df039fe54d340;hb=4c97a37dc04bd1838ea3d099bebf2900e10322dd;hp=e86badb118b80173b40affabd81615a746772b75;hpb=6bc9506f51c864af73250f5e6c99da261bd98b11;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index e86badb118b..8893c010571 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -39,13 +39,13 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; with System.Task_Info; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.IO; @@ -57,6 +57,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking; @@ -78,9 +79,6 @@ package body System.Task_Primitives.Operations is -- a time; it is used to execute in mutual exclusion from all other tasks. -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task @@ -93,13 +91,14 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; - Unblocked_Signal_Mask : aliased sigset_t; Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) + Abort_Handler_Installed : Boolean := False; + -- True if a handler for the abort signal is installed + -------------------- -- Local Packages -- -------------------- @@ -127,6 +126,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -159,10 +165,12 @@ package body System.Task_Primitives.Operations is Old_Set : aliased sigset_t; begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. + -- It's not safe to raise an exception when using GCC ZCX mechanism. + -- Note that we still need to install a signal handler, since in some + -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we + -- need to send the Abort signal to a task. - if ZCX_By_Default and then GCC_ZCX_Support then + if ZCX_By_Default then return; end if; @@ -247,7 +255,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end if; - Result := pthread_mutex_init (L, Attributes'Access); + Result := pthread_mutex_init (L.WO'Access, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then @@ -306,7 +314,7 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : not null access Lock) is Result : Interfaces.C.int; begin - Result := pthread_mutex_destroy (L); + Result := pthread_mutex_destroy (L.WO'Access); pragma Assert (Result = 0); end Finalize_Lock; @@ -327,7 +335,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - Result := pthread_mutex_lock (L); + Result := pthread_mutex_lock (L.WO'Access); Ceiling_Violation := Result = EINVAL; -- Assumes the cause of EINVAL is a priority ceiling violation @@ -373,7 +381,7 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : not null access Lock) is Result : Interfaces.C.int; begin - Result := pthread_mutex_unlock (L); + Result := pthread_mutex_unlock (L.WO'Access); pragma Assert (Result = 0); end Unlock; @@ -425,15 +433,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; + Result := + pthread_cond_wait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access)); -- EINTR is not considered a failure @@ -464,11 +469,10 @@ package body System.Task_Primitives.Operations is Timedout := True; Yielded := False; - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Duration'Min (Time, Max_Sensible_Delay) + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -476,18 +480,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := - pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -525,11 +524,10 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; + Abs_Time := + (if Mode = Relative + then Time + Check_Time + else Duration'Min (Check_Time + Max_Sensible_Delay, Time)); if Abs_Time > Check_Time then Request := To_Timespec (Abs_Time); @@ -538,17 +536,13 @@ package body System.Task_Primitives.Operations is loop exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; + Result := + pthread_cond_timedwait + (cond => Self_ID.Common.LL.CV'Access, + mutex => (if Single_Lock + then Single_RTS_Lock'Access + else Self_ID.Common.LL.L'Access), + abstime => Request'Access); Check_Time := Monotonic_Clock; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; @@ -578,7 +572,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -589,7 +583,7 @@ package body System.Task_Primitives.Operations is function RT_Resolution return Duration is begin - -- The clock_getres (Real_Time_Clock_Id) function appears to return + -- The clock_getres (OSC.CLOCK_RT_Ada) function appears to return -- the interrupt resolution of the realtime clock and not the actual -- resolution of reading the clock. Even though this last value is -- only guaranteed to be 100 Hz, at least the Origin 200 appears to @@ -709,29 +703,8 @@ package body System.Task_Primitives.Operations is (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); pragma Assert (Result = 0); end if; - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -863,9 +836,15 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); @@ -892,9 +871,15 @@ package body System.Task_Primitives.Operations is (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); pragma Assert (Result = 0); + -- Note: the use of Unrestricted_Access in the following call + -- is needed because otherwise we have an error of getting a + -- access-to-volatile value which points to a non-volatile object. + -- But in this case it is safe to do this, since we know we have no + -- aliasing problems and Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); @@ -925,12 +910,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -945,11 +925,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- @@ -968,11 +944,13 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : Interfaces.C.int; begin - Result := - pthread_kill - (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); + if Abort_Handler_Installed then + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end if; end Abort_Task; ---------------- @@ -1165,7 +1143,16 @@ package body System.Task_Primitives.Operations is S.State := False; else S.Waiting := True; - Result := pthread_cond_wait (S.CV'Access, S.L'Access); + + loop + -- Loop in case pthread_cond_wait returns earlier than expected + -- (e.g. in case of EINTR caused by a signal). + + Result := pthread_cond_wait (S.CV'Access, S.L'Access); + pragma Assert (Result = 0 or else Result = EINTR); + + exit when not S.Waiting; + end loop; end if; Result := pthread_mutex_unlock (S.L'Access); @@ -1315,6 +1302,12 @@ package body System.Task_Primitives.Operations is Specific.Initialize (Environment_Task); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Prepare the set of signals that should unblocked in all tasks @@ -1329,8 +1322,6 @@ package body System.Task_Primitives.Operations is end if; end loop; - -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then @@ -1347,7 +1338,21 @@ package body System.Task_Primitives.Operations is act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); + Abort_Handler_Installed := True; end if; end Initialize; + ----------------------- + -- Set_Task_Affinity -- + ----------------------- + + procedure Set_Task_Affinity (T : ST.Task_Id) is + pragma Unreferenced (T); + + begin + -- Setting task affinity is not supported by the underlying system + + null; + end Set_Task_Affinity; + end System.Task_Primitives.Operations;