From e0bfbf32fc83d556d3b5cd86ea33060fd0b68cb8 Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 17 Feb 2006 16:06:01 +0000 Subject: [PATCH] 2006-02-17 Jose Ruiz * s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-posix.adb, s-taprop-vxworks.adb, s-taprop-lynxos.adb, s-taprop-tru64.adb (Set_False, Set_True, Suspend_Until_True): Add Abort_Defer/Undefer pairs to avoid the possibility of a task being aborted while owning a lock. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111184 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/s-taprop-hpux-dce.adb | 32 ++++++++++++++++++++++++++++---- gcc/ada/s-taprop-irix.adb | 30 +++++++++++++++++++++++++++--- gcc/ada/s-taprop-linux.adb | 27 ++++++++++++++++++++++++--- gcc/ada/s-taprop-lynxos.adb | 30 +++++++++++++++++++++++++++--- gcc/ada/s-taprop-mingw.adb | 30 ++++++++++++++++++++++++++++++ gcc/ada/s-taprop-posix.adb | 30 +++++++++++++++++++++++++++--- gcc/ada/s-taprop-solaris.adb | 30 +++++++++++++++++++++++++++--- gcc/ada/s-taprop-tru64.adb | 30 +++++++++++++++++++++++++++--- gcc/ada/s-taprop-vms.adb | 21 ++++++++++++++++++--- gcc/ada/s-taprop-vxworks.adb | 26 ++++++++++++++++++++++++++ 10 files changed, 261 insertions(+), 25 deletions(-) diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index b72a82c321c..838f54e76f9 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -69,11 +69,21 @@ with System.Parameters; with System.Task_Primitives.Interrupt_Operations; -- used for Get_Interrupt_ID +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -955,6 +965,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -962,6 +974,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -971,6 +985,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -991,6 +1007,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1000,6 +1018,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1011,6 +1031,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1023,10 +1045,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 8b048e47257..efae88249dd 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -60,11 +60,21 @@ with System.OS_Primitives; with System.IO; -- used for Put_Line +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking; use System.Tasking.Debug; use Interfaces.C; @@ -1019,6 +1029,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1026,6 +1038,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1035,6 +1049,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1055,6 +1071,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1064,6 +1082,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1075,6 +1095,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1087,10 +1109,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 6a3596ead63..6455748751d 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -58,6 +58,11 @@ with System.OS_Primitives; with System.Soft_Links; -- used for Abort_Defer/Undefer +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Ada.Exceptions; -- used for Raise_Exception -- Raise_From_Signal_Handler @@ -68,6 +73,8 @@ with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -913,6 +920,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -920,6 +929,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -929,6 +940,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -949,6 +962,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -958,6 +973,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -969,6 +986,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -981,10 +1000,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb index a9b4cbbb823..8f53ad40a30 100644 --- a/gcc/ada/s-taprop-lynxos.adb +++ b/gcc/ada/s-taprop-lynxos.adb @@ -59,10 +59,20 @@ with Interfaces.C; -- used for int -- size_t +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -1089,6 +1099,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1096,6 +1108,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1105,6 +1119,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1125,6 +1141,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1134,6 +1152,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1145,6 +1165,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1157,10 +1179,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 7280f646dd2..953e19e101e 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -56,10 +56,23 @@ with Interfaces.C.Strings; with System.Task_Info; -- used for Unspecified_Task_Info +with System.Interrupt_Management; +-- used for Initialize + +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -983,6 +996,7 @@ package body System.Task_Primitives.Operations is begin Environment_Task_Id := Environment_Task; OS_Primitives.Initialize; + Interrupt_Management.Initialize; if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then @@ -1083,11 +1097,15 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is begin + SSL.Abort_Defer.all; + EnterCriticalSection (S.L'Access); S.State := False; LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1097,6 +1115,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : BOOL; begin + SSL.Abort_Defer.all; + EnterCriticalSection (S.L'Access); -- If there is already a task waiting on this suspension object then @@ -1115,6 +1135,8 @@ package body System.Task_Primitives.Operations is end if; LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1125,6 +1147,8 @@ package body System.Task_Primitives.Operations is Result : DWORD; Result_Bool : BOOL; begin + SSL.Abort_Defer.all; + EnterCriticalSection (S.L'Access); if S.Waiting then @@ -1134,6 +1158,8 @@ package body System.Task_Primitives.Operations is LeaveCriticalSection (S.L'Access); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1144,6 +1170,8 @@ package body System.Task_Primitives.Operations is S.State := False; LeaveCriticalSection (S.L'Access); + + SSL.Abort_Undefer.all; else S.Waiting := True; @@ -1154,6 +1182,8 @@ package body System.Task_Primitives.Operations is LeaveCriticalSection (S.L'Access); + SSL.Abort_Undefer.all; + Result := WaitForSingleObject (S.CV, Wait_Infinite); pragma Assert (Result = 0); end if; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 6195f242c75..ebe495d79de 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -64,11 +64,21 @@ with Interfaces.C; -- used for int -- size_t +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -1111,6 +1121,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1118,6 +1130,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1127,6 +1141,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1147,6 +1163,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1156,6 +1174,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1167,6 +1187,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1179,10 +1201,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index aa816b6746b..002064c66ab 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -64,10 +64,20 @@ with Interfaces.C; with System.Task_Info; -- to initialize Task_Info for a C thread, in function Self +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -1720,6 +1730,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1727,6 +1739,8 @@ package body System.Task_Primitives.Operations is Result := mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1736,6 +1750,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1756,6 +1772,8 @@ package body System.Task_Primitives.Operations is Result := mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1765,6 +1783,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1776,6 +1796,8 @@ package body System.Task_Primitives.Operations is Result := mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1788,10 +1810,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index d7e602a9e54..120657fc47e 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -61,10 +61,20 @@ with Interfaces.C; -- used for int -- size_t +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use Interfaces.C; @@ -1026,6 +1036,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1033,6 +1045,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1042,6 +1056,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1062,6 +1078,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1071,6 +1089,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1082,6 +1102,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1094,10 +1116,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 95a93b4fa25..755a2c94051 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -52,6 +52,7 @@ with Interfaces.C; with System.Soft_Links; -- used for Get_Exc_Stack_Addr +-- Abort_Defer/Undefer with Unchecked_Conversion; with Unchecked_Deallocation; @@ -985,6 +986,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -992,6 +995,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1001,6 +1006,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1021,6 +1028,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1030,6 +1039,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; begin + SSL.Abort_Defer.all; + Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); @@ -1041,6 +1052,8 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1053,10 +1066,12 @@ package body System.Task_Primitives.Operations is S.Waiting := True; Result := pthread_cond_wait (S.CV'Access, S.L'Access); end if; - end if; - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); + Result := pthread_mutex_unlock (S.L'Access); + pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; + end if; end Suspend_Until_True; ---------------- diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 56a02dda238..186e8c28f40 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -51,11 +51,21 @@ with System.Interrupt_Management; with Interfaces.C; +with System.Soft_Links; +-- used for Abort_Defer/Undefer + +-- We use System.Soft_Links instead of System.Tasking.Initialization +-- because the later is a higher level package that we shouldn't depend on. +-- For example when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Stages. + with Unchecked_Conversion; with Unchecked_Deallocation; package body System.Task_Primitives.Operations is + package SSL renames System.Soft_Links; + use System.Tasking.Debug; use System.Tasking; use System.OS_Interface; @@ -1030,6 +1040,8 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : STATUS; begin + SSL.Abort_Defer.all; + Result := semTake (S.L, WAIT_FOREVER); pragma Assert (Result = OK); @@ -1037,6 +1049,8 @@ package body System.Task_Primitives.Operations is Result := semGive (S.L); pragma Assert (Result = OK); + + SSL.Abort_Undefer.all; end Set_False; -------------- @@ -1046,6 +1060,8 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : STATUS; begin + SSL.Abort_Defer.all; + Result := semTake (S.L, WAIT_FOREVER); pragma Assert (Result = OK); @@ -1066,6 +1082,8 @@ package body System.Task_Primitives.Operations is Result := semGive (S.L); pragma Assert (Result = OK); + + SSL.Abort_Undefer.all; end Set_True; ------------------------ @@ -1075,6 +1093,8 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : STATUS; begin + SSL.Abort_Defer.all; + Result := semTake (S.L, WAIT_FOREVER); if S.Waiting then @@ -1085,6 +1105,8 @@ package body System.Task_Primitives.Operations is Result := semGive (S.L); pragma Assert (Result = OK); + SSL.Abort_Undefer.all; + raise Program_Error; else -- Suspend the task if the state is False. Otherwise, the task @@ -1096,6 +1118,8 @@ package body System.Task_Primitives.Operations is Result := semGive (S.L); pragma Assert (Result = 0); + + SSL.Abort_Undefer.all; else S.Waiting := True; @@ -1104,6 +1128,8 @@ package body System.Task_Primitives.Operations is Result := semGive (S.L); pragma Assert (Result = OK); + SSL.Abort_Undefer.all; + Result := semTake (S.CV, WAIT_FOREVER); pragma Assert (Result = 0); end if; -- 2.11.0