From: "Marc Poulhiès" <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 [thread overview]
Message-ID: <20240517083207.130391-26-poulhies@adacore.com> (raw)
In-Reply-To: <20240517083207.130391-1-poulhies@adacore.com>
From: Eric Botcazou <ebotcazou@adacore.com>
The duplication is present in some POSIX-like implementations (POSIX
and RTEMS) while it has already been eliminated in others (Linux, QNX). The
latter implementations are also slightly modified for consistency's sake.
No functional changes.
gcc/ada/
* libgnarl/s-taprop__dummy.adb (Initialize_Lock): Fix formatting.
* libgnarl/s-taprop__linux.adb (RTS_Lock_Ptr): Delete.
(Init_Mutex): Rename into...
(Initialize_Lock): ...this.
(Initialize_Lock [Lock]): Call above procedure.
(Initialize_Lock [RTS_Lock]): Likewise.
(Initialize_TCB): Likewise.
* libgnarl/s-taprop__posix.adb (Initialize_Lock): New procedure
factored out from the other two homonyms.
(Initialize_Lock [Lock]): Call above procedure.
(Initialize_Lock [RTS_Lock]): Likewise.
* libgnarl/s-taprop__qnx.adb (RTS_Lock_Ptr): Delete.
(Init_Mutex): Rename into...
(Initialize_Lock): ...this.
(Initialize_Lock [Lock]): Call above procedure.
(Initialize_Lock [RTS_Lock]): Likewise.
(Initialize_TCB): Likewise.
* libgnarl/s-taprop__rtems.adb (Initialize_Lock): New procedure
factored out from the other two homonyms.
(Initialize_Lock [Lock]): Call above procedure.
(Initialize_Lock [RTS_Lock]): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnarl/s-taprop__dummy.adb | 4 +-
gcc/ada/libgnarl/s-taprop__linux.adb | 47 ++++++++++-----------
gcc/ada/libgnarl/s-taprop__posix.adb | 61 +++++++++-------------------
gcc/ada/libgnarl/s-taprop__qnx.adb | 46 ++++++++++-----------
gcc/ada/libgnarl/s-taprop__rtems.adb | 61 +++++++++-------------------
5 files changed, 90 insertions(+), 129 deletions(-)
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;
-------------------
--
2.43.2
next prev parent reply other threads:[~2024-05-17 8:32 UTC|newest]
Thread overview: 35+ messages / expand[flat|nested] mbox.gz Atom feed top
2024-05-17 8:31 [COMMITTED 01/35] ada: Add support for 'Object_Size to pragma Compile_Time_{Warning,Error} Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 02/35] ada: Small cleanup in aggregate expansion code Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 03/35] ada: Remove superfluous Relocate_Node calls Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 04/35] ada: Fix checking range constraints within composite types Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 05/35] ada: Check subtype to avoid a precondition failure Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 06/35] ada: Fix probable copy/paste error Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 07/35] ada: Tune detection of unconstrained and tagged items in Depends contract Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 08/35] ada: Allow private items with unknown discriminants as Depends inputs Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 09/35] ada: Simplify code for private types with unknown discriminants Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 10/35] ada: Only record types with discriminants can be unconstrained Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 11/35] ada: Fix Constraint_Error on mutable assignment Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 12/35] ada: Fix crash caused by missing New_Copy_tree Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 13/35] ada: Make raise-gcc.c compatible with Clang Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 14/35] ada: gnatbind-related cleanups Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 15/35] ada: correction to " Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 16/35] ada: Fix containers' Reference_Preserving_Key functions' memory leaks Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 17/35] ada: Update docs for Resolve_Null_Array_Aggregate Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 18/35] ada: gnatbind: subprogram spec no longer exists Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 19/35] ada: Couple of adjustments coming from aliasing considerations Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 20/35] ada: Expose utility routine for processing of Depends contracts in SPARK Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 21/35] ada: Fix others error message location Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 22/35] ada: Clarify code for aggregate warnings Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 23/35] ada: Disable Equivalent_Array_Aggregate optimization if predicates involved Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 24/35] ada: Do not query the modification time of a special file Marc Poulhiès
2024-05-17 8:31 ` [COMMITTED 25/35] ada: Fix for validity checking and conditional evaluation of 'Old Marc Poulhiès
2024-05-17 8:31 ` Marc Poulhiès [this message]
2024-05-17 8:31 ` [COMMITTED 27/35] ada: Bug in computing local restrictions inherited from enclosing scopes Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 28/35] ada: Document secondary usage of Materialize_Entity flag Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 29/35] ada: Replace spinlocks with fully-fledged locks in finalization collections Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 30/35] ada: Further adjustments coming from aliasing considerations Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 31/35] ada: Restore dependency on System.OS_Interface in System.Task_Primitives Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 32/35] ada: Improve test for unprocessed preprocessor directives Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 33/35] ada: Start the initialization of the tasking runtime earlier Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 34/35] ada: Remove outdated workaround in aggregate expansion Marc Poulhiès
2024-05-17 8:32 ` [COMMITTED 35/35] ada: Improve deriving initial sizes for container aggregates Marc Poulhiès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20240517083207.130391-26-poulhies@adacore.com \
--to=poulhies@adacore.com \
--cc=ebotcazou@adacore.com \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).