diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/s-taprob.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/s-taprob.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/s-tpoben.adb | 121 | ||||
| -rw-r--r-- | gcc/ada/s-tpoben.ads | 100 | ||||
| -rw-r--r-- | gcc/ada/s-tpobop.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/s-tposen.adb | 109 | ||||
| -rw-r--r-- | gcc/ada/s-tposen.ads | 35 |
7 files changed, 345 insertions, 133 deletions
diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index ab6852dbcb6..eeee8366a64 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, Ada Core Technologies -- +-- Copyright (C) 1995-2005, AdaCore -- -- -- -- 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- -- @@ -73,6 +73,7 @@ package body System.Tasking.Protected_Objects is Ceiling_Priority : Integer) is Init_Priority : Integer := Ceiling_Priority; + begin if Init_Priority = Unspecified_Priority then Init_Priority := System.Priority'Last; @@ -80,6 +81,7 @@ package body System.Tasking.Protected_Objects is Initialize_Lock (Init_Priority, Object.L'Access); Object.Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; end Initialize_Protection; ---------- @@ -100,6 +102,17 @@ package body System.Tasking.Protected_Objects is -- generated calls must be protected with cleanup handlers to ensure -- that abort is undeferred in all cases. + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + Write_Lock (Object.L'Access, Ceiling_Violation); if Parameters.Runtime_Traces then @@ -112,12 +125,18 @@ package body System.Tasking.Protected_Objects is -- We are entering in a protected action, so that we increase the -- protected object nesting level (if pragma Detect_Blocking is - -- active). + -- active), and update the protected object's owner. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; @@ -132,6 +151,25 @@ package body System.Tasking.Protected_Objects is Ceiling_Violation : Boolean; begin + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + -- + -- Note that in this case (getting read access), several tasks may have + -- read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work reliably + -- for read locks. However, this is the approach taken for two major + -- reasosn: first, this function is not currently being used (it is + -- provided for possible future use), and second, it largely simplifies + -- the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + Read_Lock (Object.L'Access, Ceiling_Violation); if Parameters.Runtime_Traces then @@ -142,14 +180,19 @@ package body System.Tasking.Protected_Objects is raise Program_Error; end if; - -- We are entering in a protected action, so that we increase the - -- protected object nesting level (if pragma Detect_Blocking is - -- active). + -- We are entering in a protected action, so we increase the protected + -- object nesting level (if pragma Detect_Blocking is active). if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; @@ -164,17 +207,26 @@ package body System.Tasking.Protected_Objects is begin -- We are exiting from a protected action, so that we decrease the -- protected object nesting level (if pragma Detect_Blocking is - -- active). + -- active), and remove ownership of the protected object. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin - -- Cannot call this procedure without being within a protected - -- action. + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; - pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); + -- We are exiting from a protected action, so we decrease the + -- protected object nesting level. Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting - 1; diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads index 2419759131e..c28fa60ddd0 100644 --- a/gcc/ada/s-taprob.ads +++ b/gcc/ada/s-taprob.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -206,13 +206,24 @@ package System.Tasking.Protected_Objects is private type Protection is record - L : aliased Task_Primitives.Lock; + L : aliased Task_Primitives.Lock; + -- Lock used to ensure mutual exclusive access to the protected object + Ceiling : System.Any_Priority; + -- Ceiling priority associated to the protected object + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). end record; procedure Finalize_Protection (Object : in out Protection); - -- Clean up a Protection object; in particular, finalize the associated - -- Lock object. The compiler generates automatically calls to this + -- Clean up a Protection object (in particular, finalize the associated + -- Lock object). The compiler generates calls automatically to this -- procedure end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 650f756ff78..aba5666e5d7 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -206,6 +206,7 @@ package body System.Tasking.Protected_Objects.Entries is Initialize_Lock (Init_Priority, Object.L'Access); Initialization.Undefer_Abort (Self_ID); Object.Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; Object.Compiler_Info := Compiler_Info; Object.Pending_Action := False; Object.Call_In_Progress := null; @@ -231,26 +232,15 @@ package body System.Tasking.Protected_Objects.Entries is (Program_Error'Identity, "Protected Object is finalized"); end if; - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action, and the protected object nesting level must be - -- increased. + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. - if Detect_Blocking then - declare - Self_Id : constant Task_Id := STPO.Self; - begin - if Self_Id.Common.Protected_Action_Nesting > 0 then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "potentially blocking operation"); - else - -- We are entering in a protected action, so that we increase - -- the protected object nesting level. - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end if; - end; + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; end if; -- The lock is made without defering abort @@ -265,6 +255,27 @@ package body System.Tasking.Protected_Objects.Entries is pragma Assert (STPO.Self.Deferral_Level > 0); Write_Lock (Object.L'Access, Ceiling_Violation); + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; + end Lock_Entries; procedure Lock_Entries (Object : Protection_Entries_Access) is @@ -291,26 +302,23 @@ package body System.Tasking.Protected_Objects.Entries is (Program_Error'Identity, "Protected Object is finalized"); end if; - -- If pragma Detect_Blocking is active then Program_Error must be - -- raised if this potentially blocking operation is called from a - -- protected action, and the protected object nesting level must - -- be increased. - - if Detect_Blocking then - declare - Self_Id : constant Task_Id := STPO.Self; - begin - if Self_Id.Common.Protected_Action_Nesting > 0 then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "potentially blocking operation"); - else - -- We are entering in a protected action, so that we increase - -- the protected object nesting level. - - Self_Id.Common.Protected_Action_Nesting := - Self_Id.Common.Protected_Action_Nesting + 1; - end if; - end; + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + -- Note that in this case (getting read access), several tasks may + -- have read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work + -- reliably for read locks. However, this is the approach taken for two + -- major reasosn: first, this function is not currently being used (it + -- is provided for possible future use), and second, it largely + -- simplifies the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; end if; Read_Lock (Object.L'Access, Ceiling_Violation); @@ -318,6 +326,26 @@ package body System.Tasking.Protected_Objects.Entries is if Ceiling_Violation then Raise_Exception (Program_Error'Identity, "Ceiling Violation"); end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. + + if Detect_Blocking then + declare + Self_Id : constant Task_Id := Self; + + begin + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level + + Self_Id.Common.Protected_Action_Nesting := + Self_Id.Common.Protected_Action_Nesting + 1; + end; + end if; end Lock_Read_Only_Entries; -------------------- @@ -328,16 +356,23 @@ package body System.Tasking.Protected_Objects.Entries is begin -- We are exiting from a protected action, so that we decrease the -- protected object nesting level (if pragma Detect_Blocking is - -- active). + -- active), and remove ownership of the protected object. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; + begin - -- Cannot call this procedure without being within a protected - -- action. + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object - pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); + Object.Owner := Null_Task; Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting - 1; diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads index 5bef440590d..027b9c9709e 100644 --- a/gcc/ada/s-tpoben.ads +++ b/gcc/ada/s-tpoben.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -83,31 +83,49 @@ package System.Tasking.Protected_Objects.Entries is -- Note that you should never (un)lock Object.L directly, but instead -- use Lock_Entries/Unlock_Entries. - Compiler_Info : System.Address; - Call_In_Progress : Entry_Call_Link; - Ceiling : System.Any_Priority; + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Ceiling : System.Any_Priority; + -- Ceiling priority associated with the protected object + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + Old_Base_Priority : System.Any_Priority; - Pending_Action : Boolean; - -- Flag indicating that priority has been dipped temporarily - -- in order to avoid violating the priority ceiling of the lock - -- associated with this protected object, in Lock_Server. - -- The flag tells Unlock_Server or Unlock_And_Update_Server to - -- restore the old priority to Old_Base_Priority. This is needed - -- because of situations (bad language design?) where one - -- needs to lock a PO but to do so would violate the priority - -- ceiling. For example, this can happen when an entry call - -- has been requeued to a lower-priority object, and the caller - -- then tries to cancel the call while its own priority is higher - -- than the ceiling of the new PO. - Finalized : Boolean := False; - -- Set to True by Finalize to make this routine idempotent. - - Entry_Bodies : Protected_Entry_Body_Access; + -- Task's base priority when the protected operation was called + + Pending_Action : Boolean; + -- Flag indicating that priority has been dipped temporarily in order + -- to avoid violating the priority ceiling of the lock associated with + -- this protected object, in Lock_Server. The flag tells Unlock_Server + -- or Unlock_And_Update_Server to restore the old priority to + -- Old_Base_Priority. This is needed because of situations (bad + -- language design?) where one needs to lock a PO but to do so would + -- violate the priority ceiling. For example, this can happen when an + -- entry call has been requeued to a lower-priority object, and the + -- caller then tries to cancel the call while its own priority is + -- higher than the ceiling of the new PO. + + Finalized : Boolean := False; + -- Set to True by Finalize to make this routine idempotent + + Entry_Bodies : Protected_Entry_Body_Access; + -- Pointer to an array containing the executable code for all entry + -- bodies of a protected type. -- The following function maps the entry index in a call (which denotes -- the queue to the proper entry) into the body of the entry. - Find_Body_Index : Find_Body_Index_Access; + Find_Body_Index : Find_Body_Index_Access; Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); end record; @@ -141,11 +159,11 @@ package System.Tasking.Protected_Objects.Entries is -- to keep track of the runtime state of a protected object. procedure Lock_Entries (Object : Protection_Entries_Access); - -- Lock a protected object for write access. Upon return, the caller - -- owns the lock to this object, and no other call to Lock or - -- Lock_Read_Only with the same argument will return until the - -- corresponding call to Unlock has been made by the caller. - -- Program_Error is raised in case of ceiling violation. + -- Lock a protected object for write access. Upon return, the caller owns + -- the lock to this object, and no other call to Lock or Lock_Read_Only + -- with the same argument will return until the corresponding call to + -- Unlock has been made by the caller. Program_Error is raised in case of + -- ceiling violation. procedure Lock_Entries (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean); @@ -153,24 +171,24 @@ package System.Tasking.Protected_Objects.Entries is -- raising Program_Error. procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); - -- Lock a protected object for read access. Upon return, the caller - -- owns the lock for read access, and no other calls to Lock with the - -- same argument will return until the corresponding call to Unlock - -- has been made by the caller. Other calls to Lock_Read_Only may (but - -- need not) return before the call to Unlock, and the corresponding - -- callers will also own the lock for read access. + -- Lock a protected object for read access. Upon return, the caller owns + -- the lock for read access, and no other calls to Lock with the same + -- argument will return until the corresponding call to Unlock has been + -- made by the caller. Other calls to Lock_Read_Only may (but need not) + -- return before the call to Unlock, and the corresponding callers will + -- also own the lock for read access. -- - -- Note: we are not currently using this interface, it is provided - -- for possible future use. At the current time, everyone uses Lock - -- for both read and write locks. + -- Note: we are not currently using this interface, it is provided for + -- possible future use. At the current time, everyone uses Lock for both + -- read and write locks. procedure Unlock_Entries (Object : Protection_Entries_Access); - -- Relinquish ownership of the lock for the object represented by - -- the Object parameter. If this ownership was for write access, or - -- if it was for read access where there are no other read access - -- locks outstanding, one (or more, in the case of Lock_Read_Only) - -- of the tasks waiting on this lock (if any) will be given the - -- lock and allowed to return from the Lock or Lock_Read_Only call. + -- Relinquish ownership of the lock for the object represented by the + -- Object parameter. If this ownership was for write access, or if it was + -- for read access where there are no other read access locks outstanding, + -- one (or more, in the case of Lock_Read_Only) of the tasks waiting on + -- this lock (if any) will be given the lock and allowed to return from + -- the Lock or Lock_Read_Only call. private diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 3535a79ef74..3ab51b542c8 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2005, 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- -- @@ -537,6 +537,17 @@ package body System.Tasking.Protected_Objects.Operations is (Storage_Error'Identity, "not enough ATC nesting levels"); end if; + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_ID.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + Initialization.Defer_Abort (Self_ID); Lock_Entries (Object, Ceiling_Violation); @@ -889,6 +900,17 @@ package body System.Tasking.Protected_Objects.Operations is "not enough ATC nesting levels"); end if; + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + end if; + if Runtime_Traces then Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); end if; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb index 7cbf84e6ded..ded8d8401b9 100644 --- a/gcc/ada/s-tposen.adb +++ b/gcc/ada/s-tposen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2005, 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- -- @@ -333,6 +333,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is STPO.Initialize_Lock (Init_Priority, Object.L'Access); Object.Ceiling := System.Any_Priority (Init_Priority); + Object.Owner := Null_Task; Object.Compiler_Info := Compiler_Info; Object.Call_In_Progress := null; Object.Entry_Body := Entry_Body; @@ -350,59 +351,100 @@ package body System.Tasking.Protected_Objects.Single_Entry is Ceiling_Violation : Boolean; begin - -- If pragma Detect_Blocking is active then the protected object - -- nesting level must be increased. + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. if Detect_Blocking then declare - Self_Id : constant Task_Id := STPO.Self; + Self_Id : constant Task_Id := Self; + begin - -- We are entering in a protected action, so that we - -- increase the protected object nesting level. + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; end if; - - STPO.Write_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error; - end if; end Lock_Entry; -------------------------- -- Lock_Read_Only_Entry -- -------------------------- - -- Compiler interface only. - -- Do not call this procedure from within the runtime system. + -- Compiler interface only + + -- Do not call this procedure from within the runtime system procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is Ceiling_Violation : Boolean; begin - -- If pragma Detect_Blocking is active then the protected object - -- nesting level must be increased. + -- If pragma Detect_Blocking is active then, as described in the ARM + -- 9.5.1, par. 15, we must check whether this is an external call on a + -- protected subprogram with the same target object as that of the + -- protected action that is currently in progress (i.e., if the caller + -- is already the protected object's owner). If this is the case hence + -- Program_Error must be raised. + + -- Note that in this case (getting read access), several tasks may + -- have read ownership of the protected object, so that this method of + -- storing the (single) protected object's owner does not work + -- reliably for read locks. However, this is the approach taken for two + -- major reasosn: first, this function is not currently being used (it + -- is provided for possible future use), and second, it largely + -- simplifies the implementation. + + if Detect_Blocking and then Object.Owner = Self then + raise Program_Error; + end if; + + STPO.Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + -- We are entering in a protected action, so that we increase the + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and update the protected object's owner. if Detect_Blocking then declare - Self_Id : constant Task_Id := STPO.Self; + Self_Id : constant Task_Id := Self; + begin - -- We are entering in a protected action, so that we - -- increase the protected object nesting level. + -- Update the protected object's owner + + Object.Owner := Self_Id; + + -- Increase protected object nesting level Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; end if; - - STPO.Read_Lock (Object.L'Access, Ceiling_Violation); - - if Ceiling_Violation then - raise Program_Error; - end if; end Lock_Read_Only_Entry; -------------------- @@ -415,6 +457,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is Entry_Call : Entry_Call_Link) is Barrier_Value : Boolean; + begin -- When the Action procedure for an entry body returns, it must be -- completed (having called [Exceptional_]Complete_Entry_Body). @@ -423,6 +466,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is if Barrier_Value then if Object.Call_In_Progress /= null then + -- This violates the No_Entry_Queue restriction, send -- Program_Error to the caller. @@ -692,16 +736,25 @@ package body System.Tasking.Protected_Objects.Single_Entry is procedure Unlock_Entry (Object : Protection_Entry_Access) is begin -- We are exiting from a protected action, so that we decrease the - -- protected object nesting level (if pragma Detect_Blocking is active). + -- protected object nesting level (if pragma Detect_Blocking is + -- active), and remove ownership of the protected object. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin - -- Cannot call Unlock_Entry without being within protected action + -- Calls to this procedure can only take place when being within + -- a protected action and when the caller is the protected + -- object's owner. + + pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 + and then Object.Owner = Self_Id); + + -- Remove ownership of the protected object + + Object.Owner := Null_Task; - pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0); Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting - 1; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads index 148098f4cae..8ad0cb43085 100644 --- a/gcc/ada/s-tposen.ads +++ b/gcc/ada/s-tposen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -277,12 +277,33 @@ package System.Tasking.Protected_Objects.Single_Entry is private type Protection_Entry is record - L : aliased Task_Primitives.Lock; - Compiler_Info : System.Address; - Call_In_Progress : Entry_Call_Link; - Ceiling : System.Any_Priority; - Entry_Body : Entry_Body_Access; - Entry_Queue : Entry_Call_Link; + L : aliased Task_Primitives.Lock; + -- The underlying lock associated with a Protection_Entries. Note that + -- you should never (un)lock Object.L directly, but instead use + -- Lock_Entry/Unlock_Entry. + + Compiler_Info : System.Address; + -- Pointer to compiler-generated record representing protected object + + Call_In_Progress : Entry_Call_Link; + -- Pointer to the entry call being executed (if any) + + Ceiling : System.Any_Priority; + -- Ceiling priority associated to the protected object + + Owner : Task_Id; + -- This field contains the protected object's owner. Null_Task + -- indicates that the protected object is not currently being used. + -- This information is used for detecting the type of potentially + -- blocking operations described in the ARM 9.5.1, par. 15 (external + -- calls on a protected subprogram with the same target object as that + -- of the protected action). + + Entry_Body : Entry_Body_Access; + -- Pointer to executable code for the entry body of the protected type + + Entry_Queue : Entry_Call_Link; + -- Place to store the waiting entry call (if any) end record; end System.Tasking.Protected_Objects.Single_Entry; |