In this article we show how to implement a "recursive" semaphore that
can be seized multiple times by its owner without deadlock.
Suppose we have a guarded stack with an equality operator:
generic
with function "=" (L, R : Item_Type) return Boolean is <>;
package Stacks.Guarded_G is
type Stack_Type is
new Stacks.Stack_Type with record
Semaphore : aliased Semaphore_Type;
end record;
function "=" (L, R : Stack_Type) return Boolean;
...
end Stacks.Guarded_G;
In order to implement the equality operator, we need to seize the left
and right operands, and then compare the items in each stack. Our
first, naive implementation would look something like this:
function "=" (L, R : Stack_Type) return Boolean is
L_Control : Semaphore_Control (<left operand>);
R_Control : Semaphore_Control (<right operand>);
begin
if L.Top /= R.Top then
return False;
end if;
for I in Integer range 1 .. L.Top loop
if L.Items (I) /= R.Items (I) then
return False;
end if;
end loop;
return True;
end "=";
To compare two guarded stacks, you just call the equality operator in
the normal way:
declare
S1, S2 : Guarded.Stack_Type;
begin
...
if S1 = S2 then ...;
end;
The equality function first seizes S1 (the left operand), then seizes S2
(the right operand), and then compares the items.
But there is a problem. Suppose we had two separate threads, both
comparing the same pair of stacks:
package Global is
S1, S2 : Guarded.Stack_Type;
end Global;
task body T1 is
begin
if S1 = S2 then ...;
end T1;
task body T2 is
begin
if S2 = S1 then ...;
end T2;
Here is a possible sequence of actions:
T1: seize left (S1)
T2: seize left (S2)
T1: seize right (S2)
T2: seize right (S1)
The problem is that we're in a state of circular deadlock:
o T1 blocks waiting to seize S2, which has already been seized by T2.
o T2 blocks waiting to seize S1, which has already been seized by T1.
To prevent this form of deadlock, we introduce another semaphore for
binary operations (really any cardinality greater than one), that must
be seized first, prior to seizing any individual stacks:
package Stacks.Guarded_G is
...
Mutex : aliased Semaphore_Type;
end Stacks.Guarded_G;
The implementation of our modified equality operator now looks like
this:
function "=" (L, R : Stack_Type) return Boolean is
M_Control : Semaphore_Control (Mutex'Access);
L_Control : Semaphore_Control (<left operand>);
R_Control : Semaphore_Control (<right operand>);
begin
...
end "=";
This solves the circular deadlock that can result when different threads
compete for the same set of resources, because all threads have to pass
through the mutex first.
But there is still a problem. Suppose a client non-chalantly invokes
the equality function using the same argument for both operands:
if S1 = S1 then ...;
Gulp! Here's what happens:
seize left (S1)
seize right (S1)
and of course we promptly deadlock.
We could handle this as a special case by testing to see if the operands
designate the same object:
function "=" (L, R : Stack_Type) return Boolean is
begin
if L'Address = R'Address then
return True;
end if;
<as before>
end "=";
Using 'Address to determine whether the operands are the same object is
legitimate per RM95 13.3 (16), because our stack is a by-reference type.
However, we shall seek another solution, because we would prefer to not
have to handle special cases, and because using low-level facilities
(like 'Address) to solve a high-level problem lacks aesthetic appeal.
Let's implement the guarded stack using a "recursive" semaphore that
allows the current owner to seize the same stack again without deadlock.
The first thing we need is a way to record which task is the current
owner of the semaphore, and a way to compare callers to the current
owner. The package Ada.Task_Identification in the Systems Programming
Annex (C.7.1) provides all the facilities we need.
That package provides a non-limited Task_Id type to identify a task
(sort of like a Memento). There's also an attribute, E'Caller, that
returns the id of the task being serviced by an entry.
The declaration of the semaphore looks like this:
protected type Semaphore_Type is
procedure Release;
entry Seize;
private
entry Waiting;
Owner : Task_Id;
Count : Natural := 0;
end Semaphore_Type;
The implementation of the Seize entry looks like this:
entry Seize when True is
begin
if Seize'Caller = Owner then
Count := Count + 1;
else
requeue Waiting with abort;
end if;
end;
Seize checks to see if its caller already owns the semaphore. If so, we
just increment the count of the number of times Seize has been called.
The caller/owner is allowed to pass immediately, without being blocked.
Note that we have been careful to use the attribute Seize'Caller to get
the id of the task being serviced. This is different from the function
Current_Task, and it is a bounded error to use the latter function from
inside an entry body, per RM95 C.7.1 (17).
We allow Seize to be called any number of times by the same thread, but
we also require that Release be called the same number of times. When
all the seizes have been canceled by releases, this means a new thread
can assume ownership of the semaphore.
If the caller is different from the owner, we have to somehow keep the
caller waiting until the semaphore becomes available. We do this by
using requeue to put the caller on a separate wait queue, which gets
serviced when the current owner has relinquished ownership.
Seize itself doesn't ever block its callers, so its barrier is True. It
has to be a protected entry because you can only requeue a caller from
an entry, not a procedure. Note that we requeue with abort to allow a
caller to leave the queue early.
The protected procedure Release just decrements the count:
procedure Release is
begin
Count := Count - 1;
end;
After Release completes, the entry barriers are immediately reevaluated.
As long as the Count is greater than 0, then nothing else happens. It
just means the current owner still owns the semaphore, and other threads
waiting for the resource continue to wait.
When the Count drops to 0, this signifies that the current owner has
relinquished control. This opens the barrier for the Waiting entry:
entry Waiting when Count = 0 is
begin
Count := 1;
Owner := Waiting'Caller;
end;
In effect a waiting thread is allowed a "pass through" the barrier, to
become the new owner of the semaphore. We record the id of the thread,
and set Count to 1 to indicate that the resource has been claimed.
There's one last issue to deal with. As in previous articles, I like to
use a semaphore control object to make sure the semaphore is always
released.
A semaphore control object binds to its semaphore via an access
discriminant, which requires a variable view. The problem is that our
equality function takes in-mode parameters, which only provide a
constant view:
function "=" (L, R : Stack_Type) return Boolean is
How do we get a variable view of the stack, so that we can declare a
semaphore control object that binds to the stack's semaphore? The
solution is to use our friend System.Address_To_Access_Conversions.
By instantiating that package on the stack type, we get operations to
convert a stack address to an access-to-variable access object. As we
explained earlier, taking the address of the stack operand produces a
useful value because the stack is a by-reference type.
Here's the complete declarative region, showing the address to access
conversions too:
function "=" (L, R : Stack_Type) return Boolean is
M_Control : Semaphore_Control (Mutex'Access);
LA : constant Object_Pointer := To_Pointer (L'Address);
L_Control : Semaphore_Control (LA.Semaphore'Access);
RA : constant Object_Pointer := To_Pointer (R'Address);
R_Control : Semaphore_Control (RA.Semaphore'Access);
begin
<compare L and R>
end "=";
There are two test programs:
o test_semaphores:
The environment task seizes a recursive semaphore multiple times, and
then releases it.
o test_integer_stacks
Compares a pair stacks to themselves and to each other.
--STX
package body Binary_Semaphores.Controls is
procedure Initialize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Seize;
end;
procedure Finalize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Release;
end;
end Binary_Semaphores.Controls;
with Ada.Finalization;
package Binary_Semaphores.Controls is
pragma Elaborate_Body;
type Semaphore_Control (Semaphore : access Semaphore_Type) is
limited private;
private
use Ada.Finalization;
type Semaphore_Control (Semaphore : access Semaphore_Type) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Semaphore_Control);
procedure Finalize (Control : in out Semaphore_Control);
end Binary_Semaphores.Controls;
package body Binary_Semaphores is
protected body Semaphore_Type is
procedure Release is
begin
Count := Count - 1;
end;
entry Seize when True is
begin
if Seize'Caller = Owner then
Count := Count + 1;
else
requeue Waiting with abort;
end if;
end;
entry Waiting when Count = 0 is
begin
Count := 1;
Owner := Waiting'Caller;
end;
end Semaphore_Type;
end Binary_Semaphores;
with Ada.Task_Identification; use Ada.Task_Identification;
package Binary_Semaphores is
pragma Elaborate_Body;
protected type Semaphore_Type is
procedure Release;
entry Seize;
private
entry Waiting;
Owner : Task_Id;
Count : Natural := 0;
end Semaphore_Type;
end Binary_Semaphores;
with Stacks.Guarded_G;
package Integer_Stacks.Guarded is
new Integer_Stacks.Guarded_G;
with Stacks;
package Integer_Stacks is
new Stacks (Integer, Max_Depth => 10);
with Binary_Semaphores.Controls;
with System.Address_To_Access_Conversions;
package body Stacks.Guarded_G is
package Address_To_Access_Conversions is
new System.Address_To_Access_Conversions (Stack_Type);
use Address_To_Access_Conversions;
use Controls;
function "=" (L, R : Stack_Type) return Boolean is
M_Control : Semaphore_Control (Mutex'Access);
LA : constant Object_Pointer := To_Pointer (L'Address);
L_Control : Semaphore_Control (LA.Semaphore'Access);
RA : constant Object_Pointer := To_Pointer (R'Address);
R_Control : Semaphore_Control (RA.Semaphore'Access);
begin
if L.Top /= R.Top then
return False;
end if;
for I in Integer range 1 .. L.Top loop
if L.Items (I) /= R.Items (I) then
return False;
end if;
end loop;
return True;
end "=";
end Stacks.Guarded_G;
with Binary_Semaphores; use Binary_Semaphores;
generic
with function "=" (L, R : Item_Type) return Boolean is <>;
package Stacks.Guarded_G is
type Stack_Type is
new Stacks.Stack_Type with record
Semaphore : aliased Semaphore_Type;
end record;
function "=" (L, R : Stack_Type) return Boolean;
Mutex : aliased Semaphore_Type;
end Stacks.Guarded_G;
package body Stacks is
procedure Push
(Item : in Item_Type;
On : in out Stack_Type) is
begin
On.Top := On.Top + 1;
On.Items (On.Top) := Item;
end;
procedure Pop
(Stack : in out Stack_Type) is
begin
Stack.Top := Stack.Top - 1;
end;
function Get_Top
(Stack : Stack_Type) return Item_Type is
begin
return Stack.Items (Stack.Top);
end;
procedure Set_Top
(Stack : in out Stack_Type;
Item : in Item_Type) is
begin
Stack.Items (Stack.Top) := Item;
end;
function Is_Empty (Stack : Stack_Type) return Boolean is
begin
return Stack.Top = 0;
end;
procedure For_Every_Item (Stack : in out Stack_Type'Class) is
Done : Boolean := False;
begin
for I in reverse 1 .. Stack.Top loop
Process (Stack.Items (I), Done);
exit when Done;
end loop;
end For_Every_Item;
end Stacks;
generic
type Item_Type is private;
Max_Depth : in Positive;
package Stacks is
pragma Preelaborate;
type Stack_Type is tagged limited private;
procedure Push
(Item : in Item_Type;
On : in out Stack_Type);
procedure Pop
(Stack : in out Stack_Type);
function Get_Top
(Stack : Stack_Type) return Item_Type;
procedure Set_Top
(Stack : in out Stack_Type;
Item : in Item_Type);
function Is_Empty (Stack : Stack_Type) return Boolean;
generic
with procedure Process
(Item : in out Item_Type;
Done : in out Boolean);
procedure For_Every_Item (Stack : in out Stack_Type'Class);
private
subtype Item_Array_Range is Positive range 1 .. Max_Depth;
type Item_Array is array (Item_Array_Range) of Item_Type;
type Stack_Type is
tagged limited record
Items : Item_Array;
Top : Natural := 0;
end record;
end Stacks;
with Ada.Text_IO; use Ada.Text_IO;
with Integer_Stacks.Guarded;
procedure Test_Integer_Stacks is
S1, S2 : Integer_Stacks.Guarded.Stack_Type;
use Integer_Stacks;
use Guarded;
begin
Put_Line (Boolean'Image (S1 = S1));
Put_Line (Boolean'Image (S2 = S2));
Put_Line (Boolean'Image (S1 = S2));
New_Line;
Push (1, On => S1);
Put_Line (Boolean'Image (S1 = S1));
Put_Line (Boolean'Image (S2 = S2));
Put_Line (Boolean'Image (S1 = S2));
New_Line;
Push (1, On => S2);
Put_Line (Boolean'Image (S1 = S1));
Put_Line (Boolean'Image (S2 = S2));
Put_Line (Boolean'Image (S1 = S2));
New_Line;
Pop (S1);
Put_Line (Boolean'Image (S1 = S1));
Put_Line (Boolean'Image (S2 = S2));
Put_Line (Boolean'Image (S1 = S2));
New_Line;
Pop (S2);
Put_Line (Boolean'Image (S1 = S1));
Put_Line (Boolean'Image (S2 = S2));
Put_Line (Boolean'Image (S1 = S2));
New_Line;
end Test_Integer_Stacks;
with Binary_Semaphores; use Binary_Semaphores;
with Ada.Text_IO; use Ada.Text_IO;
procedure Test_Semaphores is
S : Semaphore_Type;
task Another_Task is
entry Seize_Semaphore;
end;
task body Another_Task is
begin
accept Seize_Semaphore;
Put_Line ("Another task is seizing semaphore");
S.Seize;
Put_Line ("Another task is done waiting.");
end;
begin
Put_Line ("env task is seizing semaphore");
S.Seize;
Another_Task.Seize_Semaphore;
delay 1.0;
for I in Integer range 2 .. 10 loop
Put_Line ("Env task seize" & Integer'Image (I));
S.Seize;
end loop;
Put_Line ("Env task has seized semaphore 10 times; releasing.");
for I in Integer range 1 .. 10 loop
Put_Line ("Env task release" & Integer'Image (I));
S.Release;
end loop;
end Test_Semaphores;
|
