This patch allows the locking policies Ceiling_Locking and Inheritance_Locking to be supported under Linux. No small test case is available.
Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Bob Duff <d...@adacore.com> * s-osinte-linux.ads (pthread_mutexattr_setprotocol, pthread_mutexattr_setprioceiling): Add new interfaces for these pthread operations. * s-taprop-linux.adb (Initialize_Lock, Initialize_TCB): Set protocols as appropriate for Locking_Policy 'C' and 'I'. * s-taprop-posix.adb: Minor reformatting to make it more similar to s-taprop-linux.adb.
Index: s-osinte-linux.ads =================================================================== --- s-osinte-linux.ads (revision 247135) +++ s-osinte-linux.ads (working copy) @@ -452,6 +452,20 @@ -- POSIX.1c Section 13 -- -------------------------- + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + type struct_sched_param is record sched_priority : int; -- scheduling priority end record; Index: s-taprop-linux.adb =================================================================== --- s-taprop-linux.adb (revision 247135) +++ s-taprop-linux.adb (working copy) @@ -111,6 +111,14 @@ -- Constant to indicate that the thread identifier has not yet been -- initialized. + function geteuid return Integer; + pragma Import (C, geteuid, "geteuid"); + pragma Warnings (Off, "non-static call not allowed in preelaborated unit"); + Superuser : constant Boolean := geteuid = 0; + pragma Warnings (On, "non-static call not allowed in preelaborated unit"); + -- True if we are running as 'root'. On Linux, ceiling priorities work only + -- in that case, so if this is False, we ignore Locking_Policy = 'C'. + -------------------- -- Local Packages -- -------------------- @@ -161,6 +169,11 @@ procedure Abort_Handler (signo : Signal); + function GNAT_pthread_condattr_setup + (attr : access pthread_condattr_t) return int; + pragma Import (C, + GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + ------------------- -- Abort_Handler -- ------------------- @@ -261,8 +274,6 @@ (Prio : System.Any_Priority; L : not null access Lock) is - pragma Unreferenced (Prio); - begin if Locking_Policy = 'R' then declare @@ -291,36 +302,91 @@ else declare + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; begin - Result := pthread_mutex_init (L.WO'Access, null); + 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 + if Superuser then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + end if; + + 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.WO'Access, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); raise Storage_Error with "Failed to allocate a lock"; end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end; 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); - Result : Interfaces.C.int; + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; begin - Result := pthread_mutex_init (L, null); + 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 + if Superuser 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); + end if; + + 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; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end Initialize_Lock; ------------------- @@ -361,11 +427,10 @@ Result := pthread_mutex_lock (L.WO'Access); end if; + -- The cause of EINVAL is a priority ceiling violation + Ceiling_Violation := Result = EINVAL; - - -- Assume the cause of EINVAL is a priority ceiling violation - - pragma Assert (Result = 0 or else Result = EINVAL); + pragma Assert (Result = 0 or else Ceiling_Violation); end Write_Lock; procedure Write_Lock @@ -405,11 +470,10 @@ Result := pthread_mutex_lock (L.WO'Access); end if; + -- The cause of EINVAL is a priority ceiling violation + Ceiling_Violation := Result = EINVAL; - - -- Assume the cause of EINVAL is a priority ceiling violation - - pragma Assert (Result = 0 or else Result = EINVAL); + pragma Assert (Result = 0 or else Ceiling_Violation); end Read_Lock; ------------ @@ -855,8 +919,9 @@ -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; begin -- Give the task a unique serial number @@ -868,24 +933,63 @@ Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := - pthread_mutex_init (Self_ID.Common.LL.L'Access, null); + Result := pthread_mutexattr_init (Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); + if Result = 0 then + if Locking_Policy = 'C' then + if Superuser then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + end if; + + elsif Locking_Policy = 'I' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + if Result /= 0 then Succeeded := False; return; end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); end if; 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 + Result := GNAT_pthread_condattr_setup (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); + end if; + + if Result = 0 then Succeeded := True; else if not Single_Lock then @@ -895,6 +999,9 @@ Succeeded := False; end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); end Initialize_TCB; ----------------- @@ -1042,12 +1149,11 @@ -- 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)); + 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); Index: s-taprop-posix.adb =================================================================== --- s-taprop-posix.adb (revision 247135) +++ s-taprop-posix.adb (working copy) @@ -352,12 +352,11 @@ -- 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. + -- 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. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -474,10 +473,10 @@ begin Result := pthread_mutex_lock (L.WO'Access); - -- Assume that the cause of EINVAL is a priority ceiling violation + -- The cause of EINVAL is a priority ceiling violation - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); end Write_Lock; procedure Write_Lock