[COMMITTED,26/35] ada: Factor out duplicated code in bodies of System.Task_Primitives.Operations

Message ID	20240517083207.130391-26-poulhies@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org> DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D2087384AB44 From: =?utf-8?q?Marc_Poulhi=C3=A8s?= <poulhies@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou <ebotcazou@adacore.com> Subject: [COMMITTED 26/35] ada: Factor out duplicated code in bodies of System.Task_Primitives.Operations Date: Fri, 17 May 2024 10:31:58 +0200 Message-ID: <20240517083207.130391-26-poulhies@adacore.com> In-Reply-To: <20240517083207.130391-1-poulhies@adacore.com> References: <20240517083207.130391-1-poulhies@adacore.com> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Precedence: list Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org
Series	[COMMITTED,01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning, Error} \| expand [COMMITTED,01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning, Error} [COMMITTED,02/35] ada: Small cleanup in aggregate expansion code [COMMITTED,03/35] ada: Remove superfluous Relocate_Node calls [COMMITTED,04/35] ada: Fix checking range constraints within composite types [COMMITTED,05/35] ada: Check subtype to avoid a precondition failure [COMMITTED,06/35] ada: Fix probable copy/paste error [COMMITTED,07/35] ada: Tune detection of unconstrained and tagged items in Depends contract [COMMITTED,08/35] ada: Allow private items with unknown discriminants as Depends inputs [COMMITTED,09/35] ada: Simplify code for private types with unknown discriminants [COMMITTED,10/35] ada: Only record types with discriminants can be unconstrained [COMMITTED,11/35] ada: Fix Constraint_Error on mutable assignment [COMMITTED,12/35] ada: Fix crash caused by missing New_Copy_tree [COMMITTED,13/35] ada: Make raise-gcc.c compatible with Clang [COMMITTED,14/35] ada: gnatbind-related cleanups [COMMITTED,15/35] ada: correction to gnatbind-related cleanups [COMMITTED,16/35] ada: Fix containers' Reference_Preserving_Key functions' memory leaks [COMMITTED,17/35] ada: Update docs for Resolve_Null_Array_Aggregate [COMMITTED,18/35] ada: gnatbind: subprogram spec no longer exists [COMMITTED,19/35] ada: Couple of adjustments coming from aliasing considerations [COMMITTED,20/35] ada: Expose utility routine for processing of Depends contracts in SPARK [COMMITTED,21/35] ada: Fix others error message location [COMMITTED,22/35] ada: Clarify code for aggregate warnings [COMMITTED,23/35] ada: Disable Equivalent_Array_Aggregate optimization if predicates involved [COMMITTED,24/35] ada: Do not query the modification time of a special file. [COMMITTED,25/35] ada: Fix for validity checking and conditional evaluation of 'Old [COMMITTED,26/35] ada: Factor out duplicated code in bodies of System.Task_Primitives.Operations [COMMITTED,27/35] ada: Bug in computing local restrictions inherited from enclosing scopes. [COMMITTED,28/35] ada: Document secondary usage of Materialize_Entity flag [COMMITTED,29/35] ada: Replace spinlocks with fully-fledged locks in finalization collections [COMMITTED,30/35] ada: Further adjustments coming from aliasing considerations [COMMITTED,31/35] ada: Restore dependency on System.OS_Interface in System.Task_Primitives [COMMITTED,32/35] ada: Improve test for unprocessed preprocessor directives [COMMITTED,33/35] ada: Start the initialization of the tasking runtime earlier [COMMITTED,34/35] ada: Remove outdated workaround in aggregate expansion [COMMITTED,35/35] ada: Improve deriving initial sizes for container aggregates

diff --git a/gcc/ada/libgnarl/s-taprop__dummy.adb b/gcc/ada/libgnarl/s-taprop__dummy.adb index 90c4cd4cf72..829d595694c 100644 --- a/gcc/ada/libgnarl/s-taprop__dummy.adb +++ b/gcc/ada/libgnarl/s-taprop__dummy.adb @@ -239,7 +239,9 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) is + (L : not null access RTS_Lock; + Level : Lock_Level) + is begin null; end Initialize_Lock; diff --git a/gcc/ada/libgnarl/s-taprop__linux.adb b/gcc/ada/libgnarl/s-taprop__linux.adb index d6a29b5e158..74717cb2d2b 100644 --- a/gcc/ada/libgnarl/s-taprop__linux.adb +++ b/gcc/ada/libgnarl/s-taprop__linux.adb @@ -248,10 +248,10 @@ package body System.Task_Primitives.Operations is -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have -- permission, then a request for Ceiling_Locking is ignored. - type RTS_Lock_Ptr is not null access all RTS_Lock; - - function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int; - -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling + function Initialize_Lock + (L : not null access RTS_Lock; + Prio : Any_Priority) return C.int; + -- Initialize the lock L. If Ceiling_Support is True, then set the ceiling -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory. ------------------- @@ -340,11 +340,20 @@ package body System.Task_Primitives.Operations is function Self return Task_Id renames Specific.Self; - ---------------- - -- Init_Mutex -- - ---------------- + --------------------- + -- Initialize_Lock -- + --------------------- - function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. + + function Initialize_Lock + (L : not null access RTS_Lock; + Prio : Any_Priority) return C.int + is Mutex_Attr : aliased pthread_mutexattr_t; Result, Result_2 : C.int; @@ -377,17 +386,7 @@ package body System.Task_Primitives.Operations is Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access); pragma Assert (Result_2 = 0); return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy - end Init_Mutex; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. + end Initialize_Lock; procedure Initialize_Lock (Prio : Any_Priority; @@ -420,18 +419,19 @@ package body System.Task_Primitives.Operations is end; else - if Init_Mutex (L.WO'Access, Prio) = ENOMEM then + if Initialize_Lock (L.WO'Access, Prio) = ENOMEM then raise Storage_Error with "Failed to allocate a lock"; end if; end if; end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); begin - if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then + if Initialize_Lock (L, Any_Priority'Last) = ENOMEM then raise Storage_Error with "Failed to allocate a lock"; end if; end Initialize_Lock; @@ -840,7 +840,8 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := Null_Thread_Id; - if Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0 then + if Initialize_Lock (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0 + then Succeeded := False; return; end if; diff --git a/gcc/ada/libgnarl/s-taprop__posix.adb b/gcc/ada/libgnarl/s-taprop__posix.adb index 79694129227..a71e42112ac 100644 --- a/gcc/ada/libgnarl/s-taprop__posix.adb +++ b/gcc/ada/libgnarl/s-taprop__posix.adb @@ -211,6 +211,11 @@ package body System.Task_Primitives.Operations is pragma Import (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Prio : System.Any_Priority); + -- Initialize an RTS_Lock with the specified priority + ------------------- -- Abort_Handler -- ------------------- @@ -319,11 +324,11 @@ package body System.Task_Primitives.Operations is -- routines should be able to be handled safely. procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) + (L : not null access RTS_Lock; + Prio : System.Any_Priority) is Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); @@ -348,7 +353,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end if; - Result := pthread_mutex_init (L.WO'Access, Attributes'Access); + Result := pthread_mutex_init (L, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then @@ -361,46 +366,20 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (Prio : System.Any_Priority; + L : not null access Lock) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; + Initialize_Lock (L.WO'Access, Prio); + end Initialize_Lock; - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + begin + Initialize_Lock (L, System.Any_Priority'Last); end Initialize_Lock; ------------------- diff --git a/gcc/ada/libgnarl/s-taprop__qnx.adb b/gcc/ada/libgnarl/s-taprop__qnx.adb index 8b98af7284e..2f11d2821fb 100644 --- a/gcc/ada/libgnarl/s-taprop__qnx.adb +++ b/gcc/ada/libgnarl/s-taprop__qnx.adb @@ -115,10 +115,10 @@ package body System.Task_Primitives.Operations is Abort_Handler_Installed : Boolean := False; -- True if a handler for the abort signal is installed - type RTS_Lock_Ptr is not null access all RTS_Lock; - - function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return int; - -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling + function Initialize_Lock + (L : not null access RTS_Lock; + Prio : Any_Priority) return int; + -- Initialize the lock L. If Ceiling_Support is True, then set the ceiling -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory. function Get_Policy (Prio : System.Any_Priority) return Character; @@ -319,11 +319,19 @@ package body System.Task_Primitives.Operations is function Self return Task_Id renames Specific.Self; - ---------------- - -- Init_Mutex -- - ---------------- + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. - function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return int + function Initialize_Lock + (L : not null access RTS_Lock; + Prio : Any_Priority) return int is Attributes : aliased pthread_mutexattr_t; Result : int; @@ -365,35 +373,26 @@ package body System.Task_Primitives.Operations is pragma Assert (Result_2 = 0); return Result; - end Init_Mutex; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. + end Initialize_Lock; procedure Initialize_Lock (Prio : System.Any_Priority; L : not null access Lock) is begin - if Init_Mutex (L.WO'Access, Prio) = ENOMEM then + if Initialize_Lock (L.WO'Access, Prio) = ENOMEM then raise Storage_Error with "Failed to allocate a lock"; end if; end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); begin - if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then + if Initialize_Lock (L, Any_Priority'Last) = ENOMEM then raise Storage_Error with "Failed to allocate a lock"; end if; end Initialize_Lock; @@ -706,7 +705,8 @@ package body System.Task_Primitives.Operations is Next_Serial_Number := Next_Serial_Number + 1; pragma Assert (Next_Serial_Number /= 0); - Result := Init_Mutex (Self_ID.Common.LL.L'Access, Any_Priority'Last); + Result := + Initialize_Lock (Self_ID.Common.LL.L'Access, Any_Priority'Last); pragma Assert (Result = 0); if Result /= 0 then diff --git a/gcc/ada/libgnarl/s-taprop__rtems.adb b/gcc/ada/libgnarl/s-taprop__rtems.adb index 68a956e5c06..b041592cbe0 100644 --- a/gcc/ada/libgnarl/s-taprop__rtems.adb +++ b/gcc/ada/libgnarl/s-taprop__rtems.adb @@ -202,6 +202,11 @@ package body System.Task_Primitives.Operations is pragma Import (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Prio : System.Any_Priority); + -- Initialize an RTS_Lock with the specified priority + ------------------- -- Abort_Handler -- ------------------- @@ -329,11 +334,11 @@ package body System.Task_Primitives.Operations is -- routines should be able to be handled safely. procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) + (L : not null access RTS_Lock; + Prio : System.Any_Priority) is Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); @@ -358,7 +363,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); end if; - Result := pthread_mutex_init (L.WO'Access, Attributes'Access); + Result := pthread_mutex_init (L, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then @@ -371,46 +376,20 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (Prio : System.Any_Priority; + L : not null access Lock) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; + Initialize_Lock (L.WO'Access, Prio); + end Initialize_Lock; - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); + procedure Initialize_Lock + (L : not null access RTS_Lock; + Level : Lock_Level) + is + pragma Unreferenced (Level); + begin + Initialize_Lock (L, System.Any_Priority'Last); end Initialize_Lock; -------------------

[COMMITTED,26/35] ada: Factor out duplicated code in bodies of System.Task_Primitives.Operations

Commit Message

Patch