Recursive Semaphores

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;