s-taprob.adb (Initialize_Protection): Initialize the protected object's owner to Null_Task.
2005-03-17 Jose Ruiz <ruiz@adacore.com> * s-taprob.adb (Initialize_Protection): Initialize the protected object's owner to Null_Task. (Lock): If pragma Detect_Blocking is in effect and the caller of this procedure is already the protected object's owner then Program_Error is raised. In addition the protected object's owner is updated. (Lock_Read_Only): If pragma Detect_Blocking is in effect and the caller of this procedure is already the protected object's owner then Program_Error is raised. In addition the protected object's owner is updated. (Unlock): Remove the ownership of the protected object. * s-taprob.ads (Protection): Add the field Owner, used to store the protected object's owner. This component is needed for detecting one type of potentially blocking operations (external calls on a protected subprogram with the same target object as that of the protected action). Document the rest of the components. * s-tposen.adb, s-tpoben.adb (Initialize_Protection_Entries): Initialize the protected object's owner to Null_Task. (Lock_Read_Only_Entries): If pragma Detect_Blocking is in effect and the caller of this procedure is already the protected object's owner then Program_Error is raised. Do not raise Program_Error when this procedure is called from a protected action. (Unlock_Entries): Remove the ownership of the protected object. (Lock_Entries): If pragma Detect_Blocking is in effect and the caller of this procedure is already the protected object's owner then Program_Error is raised. Do not raise Program_Error when this procedure is called from a protected action. * s-tposen.ads, s-tpoben.ads (Protection_Entries): Add the field Owner, used to store the protected object's owner. * s-tpobop.adb (Protected_Entry_Call): If pragma Detect_Blocking is in effect and this procedure (a potentially blocking operation) is called from whithin a protected action, Program_Error is raised. (Timed_Protected_Entry_Call): If pragma Detect_Blocking is in effect and this procedure (a potentially blocking operation) is called from whithin a protected action, Program_Error is raised. From-SVN: r96675
This commit is contained in:
Jose Ruiz
Arnaud Charlet
parent
725e2a15a1
commit
ce65449a35
|
|
@ -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);
|
||||
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;
|
||||
|
||||
-- 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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 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.
|
||||
-- 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.
|
||||
|
||||
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;
|
||||
|
||||
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.
|
||||
|
||||
pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
|
||||
begin
|
||||
-- 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;
|
||||
|
||||
Self_Id.Common.Protected_Action_Nesting :=
|
||||
Self_Id.Common.Protected_Action_Nesting - 1;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
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.
|
||||
Compiler_Info : System.Address;
|
||||
-- Pointer to compiler-generated record representing protected object
|
||||
|
||||
Entry_Bodies : Protected_Entry_Body_Access;
|
||||
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;
|
||||
-- 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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,19 +351,15 @@ 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 then
|
||||
declare
|
||||
Self_Id : constant Task_Id := STPO.Self;
|
||||
begin
|
||||
-- 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 Detect_Blocking and then Object.Owner = Self then
|
||||
raise Program_Error;
|
||||
end if;
|
||||
|
||||
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
|
||||
|
|
@ -370,32 +367,57 @@ package body System.Tasking.Protected_Objects.Single_Entry is
|
|||
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 := 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_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.
|
||||
|
||||
if Detect_Blocking then
|
||||
declare
|
||||
Self_Id : constant Task_Id := STPO.Self;
|
||||
begin
|
||||
-- We are entering in a protected action, so that we
|
||||
-- increase the protected object nesting level.
|
||||
-- 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.
|
||||
|
||||
Self_Id.Common.Protected_Action_Nesting :=
|
||||
Self_Id.Common.Protected_Action_Nesting + 1;
|
||||
end;
|
||||
if Detect_Blocking and then Object.Owner = Self then
|
||||
raise Program_Error;
|
||||
end if;
|
||||
|
||||
STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
|
||||
|
|
@ -403,6 +425,26 @@ package body System.Tasking.Protected_Objects.Single_Entry is
|
|||
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 := 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_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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue