Skip to content

R
riscv-gcc-1
Commit ce65449a by Jose Ruiz Committed by Arnaud Charlet
Options

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
parent 725e2a15
Showing with 345 additions and 133 deletions
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;
......
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;
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;
......
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
......
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;
......
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;
......
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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment