X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fs-taprop-linux.adb;h=4e69ea4b321ad539db24a8b4b7a65bdec63e0588;hb=c75a2739c2dd84336557e95cf655eceb163fc341;hp=a47e4b1a0a0b513fc90f2b664d935fa7ed435cfc;hpb=99f61ee1b47f764fc7943c6c2a99becdcc00b787;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index a47e4b1a0a0..4e69ea4b321 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -38,8 +38,6 @@ 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 Ada.Unchecked_Deallocation; - with Interfaces.C; with System.Task_Info; @@ -97,11 +95,8 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - -- The following are effectively constants, but they need to be initialized - -- by calling a pthread_ function. - - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) @@ -143,6 +138,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 -- --------------------------------- @@ -261,15 +263,45 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Prio); - Result : Interfaces.C.int; - begin - Result := pthread_mutex_init (L, Mutex_Attr'Access); + if Locking_Policy = 'R' then + declare + RWlock_Attr : aliased pthread_rwlockattr_t; + Result : Interfaces.C.int; - pragma Assert (Result = 0 or else Result = ENOMEM); + begin + -- Set the rwlock to prefer writer to avoid writers starvation - if Result = ENOMEM then - raise Storage_Error with "Failed to allocate a lock"; + Result := pthread_rwlockattr_init (RWlock_Attr'Access); + pragma Assert (Result = 0); + + Result := pthread_rwlockattr_setkind_np + (RWlock_Attr'Access, + PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP); + pragma Assert (Result = 0); + + Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + end; + + else + declare + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_init (L.WO'Access, null); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error with "Failed to allocate a lock"; + end if; + end; end if; end Initialize_Lock; @@ -282,7 +314,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - Result := pthread_mutex_init (L, Mutex_Attr'Access); + Result := pthread_mutex_init (L, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -298,7 +330,11 @@ 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); + if Locking_Policy = 'R' then + Result := pthread_rwlock_destroy (L.RW'Access); + else + Result := pthread_mutex_destroy (L.WO'Access); + end if; pragma Assert (Result = 0); end Finalize_Lock; @@ -319,7 +355,12 @@ package body System.Task_Primitives.Operations is is Result : Interfaces.C.int; begin - Result := pthread_mutex_lock (L); + if Locking_Policy = 'R' then + Result := pthread_rwlock_wrlock (L.RW'Access); + else + Result := pthread_mutex_lock (L.WO'Access); + end if; + Ceiling_Violation := Result = EINVAL; -- Assume the cause of EINVAL is a priority ceiling violation @@ -356,8 +397,19 @@ package body System.Task_Primitives.Operations is (L : not null access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; begin - Write_Lock (L, Ceiling_Violation); + if Locking_Policy = 'R' then + Result := pthread_rwlock_rdlock (L.RW'Access); + else + Result := pthread_mutex_lock (L.WO'Access); + end if; + + Ceiling_Violation := Result = EINVAL; + + -- Assume the cause of EINVAL is a priority ceiling violation + + pragma Assert (Result = 0 or else Result = EINVAL); end Read_Lock; ------------ @@ -367,7 +419,11 @@ 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); + if Locking_Policy = 'R' then + Result := pthread_rwlock_unlock (L.RW'Access); + else + Result := pthread_mutex_unlock (L.WO'Access); + end if; pragma Assert (Result = 0); end Unlock; @@ -729,15 +785,6 @@ package body System.Task_Primitives.Operations is end if; 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 -- ------------------- @@ -762,7 +809,8 @@ package body System.Task_Primitives.Operations is -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; begin -- Give the task a unique serial number @@ -774,8 +822,8 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := + pthread_mutex_init (Self_ID.Common.LL.L'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then @@ -784,8 +832,11 @@ package body System.Task_Primitives.Operations is end if; end if; - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then @@ -818,6 +869,20 @@ package body System.Task_Primitives.Operations is use type System.Multiprocessors.CPU_Range; begin + -- Check whether both Dispatching_Domain and CPU are specified for + -- the task, and the CPU value is not contained within the range of + -- processors for the domain. + + if T.Common.Domain /= null + and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU + and then + (T.Common.Base_CPU not in T.Common.Domain'Range + or else not T.Common.Domain (T.Common.Base_CPU)) + then + Succeeded := False; + return; + end if; + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size); @@ -830,8 +895,7 @@ package body System.Task_Primitives.Operations is end if; Result := - pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); + pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Result := @@ -855,22 +919,26 @@ package body System.Task_Primitives.Operations is elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then declare - CPU_Set : aliased cpu_set_t := (bits => (others => False)); + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); + CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); + begin - CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + CPU_ZERO (Size, CPU_Set); + System.OS_Interface.CPU_SET + (int (T.Common.Base_CPU), Size, CPU_Set); Result := - pthread_attr_setaffinity_np - (Attributes'Access, - CPU_SETSIZE / 8, - CPU_Set'Access); + pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); end; -- Handle Task_Info - elsif T.Common.Task_Info /= null - and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU - then + elsif T.Common.Task_Info /= null then Result := pthread_attr_setaffinity_np (Attributes'Access, @@ -880,24 +948,40 @@ package body System.Task_Primitives.Operations is -- Handle dispatching domains - elsif T.Common.Domain /= null then + -- To avoid changing CPU affinities when not needed, we set the + -- affinity only when assigning to a domain other than the default + -- one, or when the default one has been modified. + + elsif T.Common.Domain /= null and then + (T.Common.Domain /= ST.System_Domain + or else T.Common.Domain.all /= + (Multiprocessors.CPU'First .. + Multiprocessors.Number_Of_CPUs => True)) + then declare - CPU_Set : aliased cpu_set_t := (bits => (others => False)); + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); + CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); begin + CPU_ZERO (Size, CPU_Set); + -- Set the affinity to all the processors belonging to the -- dispatching domain. for Proc in T.Common.Domain'Range loop - CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc); + if T.Common.Domain (Proc) then + System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); + end if; end loop; Result := - pthread_attr_setaffinity_np - (Attributes'Access, - CPU_SETSIZE / 8, - CPU_Set'Access); + pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set); pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); end; end if; @@ -906,11 +990,19 @@ 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. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + -- 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'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); @@ -934,12 +1026,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 @@ -953,12 +1040,10 @@ package body System.Task_Primitives.Operations is if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; + SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); - Free (Tmp); - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- @@ -1001,7 +1086,7 @@ package body System.Task_Primitives.Operations is -- Initialize internal mutex - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + Result := pthread_mutex_init (S.L'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -1011,7 +1096,7 @@ package body System.Task_Primitives.Operations is -- Initialize internal condition variable - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + Result := pthread_cond_init (S.CV'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -1304,12 +1389,6 @@ package body System.Task_Primitives.Operations is 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 @@ -1370,9 +1449,12 @@ package body System.Task_Primitives.Operations is and then T.Common.LL.Thread /= Null_Thread_Id then declare - type cpu_set_t_ptr is access all cpu_set_t; - + CPUs : constant size_t := + Interfaces.C.size_t + (System.Multiprocessors.Number_Of_CPUs); CPU_Set : cpu_set_t_ptr := null; + Size : constant size_t := CPU_ALLOC_SIZE (CPUs); + Result : Interfaces.C.int; begin @@ -1384,14 +1466,14 @@ package body System.Task_Primitives.Operations is -- Set the affinity to an unique CPU - CPU_Set := new cpu_set_t'(bits => (others => False)); - CPU_Set.bits (Integer (T.Common.Base_CPU)) := True; + CPU_Set := CPU_ALLOC (CPUs); + System.OS_Interface.CPU_ZERO (Size, CPU_Set); + System.OS_Interface.CPU_SET + (int (T.Common.Base_CPU), Size, CPU_Set); -- Handle Task_Info - elsif T.Common.Task_Info /= null - and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU - then + elsif T.Common.Task_Info /= null then CPU_Set := T.Common.Task_Info.CPU_Affinity'Access; -- Handle dispatching domains @@ -1408,10 +1490,11 @@ package body System.Task_Primitives.Operations is -- domain other than the default one, or when the default one -- has been modified. - CPU_Set := new cpu_set_t'(bits => (others => False)); + CPU_Set := CPU_ALLOC (CPUs); + System.OS_Interface.CPU_ZERO (Size, CPU_Set); for Proc in T.Common.Domain'Range loop - CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc); + System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set); end loop; end if; @@ -1422,9 +1505,10 @@ package body System.Task_Primitives.Operations is if CPU_Set /= null then Result := - pthread_setaffinity_np - (T.Common.LL.Thread, CPU_SETSIZE / 8, CPU_Set); + pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set); pragma Assert (Result = 0); + + CPU_FREE (CPU_Set); end if; end; end if;