Do Not Entry: Bounded Queue of Suspension Objects

In an earlier implementation of the dining philosophers example, we used
suspension objects to keep philosopher tasks waiting for chopsticks.
This allowed us to implement the Chopsticks protected object without
using an entry queue.

Here we extend that idea to the Line_Views package.  Previously, tasks
that call Update would get queued on the Wait entry of a semaphore, to
serialize access to package state and to Text_IO.  Now, in this
alternate implementation, we suspend the calling task using its
suspension object.

Implementation

If the Line_Views resource is already in use (meaning that another task
is in the middle of calling Update), then instead waiting in a protected
object entry queue, the calling task suspends itself on a suspension
object.

We use a special, entry-less semaphore object containing a queue of
(pointers to) suspension objects.  During Update, a pointer to the
task's suspension object is added to the queue.  When the task who owns
the resource is done (has left its critical region), it signals the task
at the front of the queue.

If the task calling Update finds that the resource isn't already in use,
then its suspension object is set to True immediately, and the task
proceeds without any waiting.

The spec of the semaphore looks like this:

   protected type Semaphore_Type (Size : Positive) is

      procedure Wait (SO : in Suspension_Object_Access);

      procedure Signal;

   private

      Queue : Queue_Type (Size);

      In_Use : Boolean := False;

   end Semaphore_Type;


This is a bounded semaphore, and we pass in the maximum number of tasks
as a discriminant.

The In_Use flag indicates whether another thread has already claimed the
resource, and Queue is just a bounded queue of pointers to suspension
objects.

Associated with each task is a suspension object.  In order to use a
resource, the task "registers" its suspension object with the semaphore,
and then immediately following that calls Suspend_Until_True.

The span of a task's critical region looks a little like this:

  Semaphore.Wait (My_Suspension_Object'Access);

  Suspend_Until_True (My_Suspension_Object);

  <critical region>

  Semaphore.Signal;


Note that the name Wait is a bit of a misnomer (it's a protected
procedure, not an entry), because no real waiting occurs until calling
Suspend_Until_True, and only then if the suspension object has the value
False.

Wait is implemented as follows:

      procedure Wait (SO : in Suspension_Object_Access) is
      begin
         if In_Use then
            Add (SO, To => Queue);
            Set_False (SO.all);
         else
            In_Use := True;
            Set_True (SO.all);
         end if;
      end Wait;

If the semaphore is in use, then we set the suspension object to False,
to actually suspend the calling task, and add the suspension object to
the queue.

Otherwise, we set the In_Use flag to indicate that the resource has been
claimed, and set the task's suspension object to True.  When the task
calls Suspend_Until_True, the suspension object will already be True,
and the task enters its critical region right away.

When the task leaves its critical region, it calls Signal:

      procedure Signal is
      begin
         pragma Assert (In_Use);

         if Is_Empty (Queue) then
            In_Use := False;
         else
            Set_True (Get_Front (Queue).all);
            Pop (Queue);
         end if;
      end Signal;

An empty queue means there's no other task waiting to use the resource,
so we just set the In_Use flag is to False, and we're done.  Otherwise,
we resume the waiting task at the front of the queue, and remove that
task from the queue.

In order to use this semaphore, the Line_Views package needs suspension
objects.  Since this package is part of the Philosophers subsystem, we
will reuse the suspension objects already being used for chopstick
management.

We move the suspension object array out of the body of the Philosophers
package, and into the spec of a private Internals package:

  private package Philosophers.Internals is

     type Suspension_Object_Array is
        array (Philosopher_Id) of aliased Suspension_Object;

     Semaphores : Suspension_Object_Array;

  end Philosophers.Internals;


Making the package private hides the package from clients outside the
subsystem.  Only packages (really, their bodies) that are children of
package Philosophers are allowed to with Internals.  In a sense, package
Internals is the "body" of the subsystem.

Now that a suspension object is available, we can implement the Update
operation:

   Number_Of_Philosophers : constant := Philosopher_Id'Last;

   LV_Sema_Size : constant := Number_Of_Philosophers - 1;

   LV_Sema : Semaphores.Bounded.Semaphore_Type (LV_Sema_Size);


   procedure Update
     (Id    : in Philosopher_Id;
      State : in State_Type) is

      SO : Suspension_Object renames Internals.Semaphores (Id);

   begin

      LV_Sema.Wait (SO'Access);
      Suspend_Until_True (SO);

      Do_Update (Id, State);

      LV_Sema.Signal;

   end Update;


The task registers its suspension object with the semaphore, by calling
Wait, and then suspends itself.  When the current task (the owner of the
the resource) is done, it signals the semaphore, and that resumes the
suspended task.

I should have implemented Update using a Controlled object to make sure
Signal gets called, and in a real system I probably would.  I didn't do
it that way here because I was trying to keep the focus on the use of a
suspension object as an alternative to an entry queue.

A note about the size of the semaphore queue.  There are five tasks
total, but if one task is executing, we only need keep a maximum of four
tasks waiting.  That's why the size of the semaphore queue is four
instead of five.

This particular example is similar to the example in section D.10 of the
Ada95 Rationale.  You may find it helpful to peruse that section.

The sources below are in a format suitable for use with gnatchop.

--STX
with Ada.Text_IO;

package Duration_IO is
  new Ada.Text_IO.Fixed_IO (Duration);

with Ada.Synchronous_Task_Control;  use Ada.Synchronous_Task_Control;

private package Philosophers.Internals is

   type Suspension_Object_Array is
      array (Philosopher_Id) of aliased Suspension_Object;

   Semaphores : Suspension_Object_Array;

end Philosophers.Internals;



with Ada.Text_IO;             use Ada.Text_IO;
with Duration_IO;             use Duration_IO;
with Philosophers.Internals;
with Semaphores.Bounded;
with Ada.Synchronous_Task_Control;  use Ada.Synchronous_Task_Control;

package body Philosophers.Line_Views is

   Number_Of_Philosophers : constant := Philosopher_Id'Last;

   LV_Sema_Size : constant := Number_Of_Philosophers - 1;

   LV_Sema : Semaphores.Bounded.Semaphore_Type (LV_Sema_Size);

   Current : Natural := 0;

   Count : Natural := Philosopher_Id'Last;


   procedure Do_Update
     (Id    : in Philosopher_Id;
      State : in State_Type) is

   begin

      if Current = Id then
         Put (", ");
      else
         New_Line;
         Current := Id;
         Put ("Philosopher" & Philosopher_Id'Image (Id) & " ");
      end if;

      Put (State_Type'Image (State));

      if State = Eating
        or State = Thinking
      then

         Put (" (");
         Put (Get_Delay (Id), Fore => 0, Aft => 1, Exp => 0);
         Put (")");

      elsif State = Dying then

         Count := Count - 1;

         if Count = 0 then
            New_Line (2);
            Put_Line ("All the philosophers have terminated.");
         end if;

      end if;

   exception
      when others =>
         Put_Line ("An error occured updating philosopher task" &
                   Integer'Image (Id) &
                   " in state " &
                   State_Type'Image (State));

   end Do_Update;


   procedure Update
     (Id    : in Philosopher_Id;
      State : in State_Type) is

      SO : Suspension_Object renames Internals.Semaphores (Id);

   begin

      LV_Sema.Wait (SO'Access);
      Suspend_Until_True (SO);

      Do_Update (Id, State);

      LV_Sema.Signal;

   end Update;

end Philosophers.Line_Views;
package Philosophers.Line_Views is

   pragma Elaborate_Body;

   procedure Update
     (Id    : in Philosopher_Id;
      State : in State_Type);

end Philosophers.Line_Views;




with Ada.Numerics.Float_Random;    use Ada.Numerics.Float_Random;
with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
with Ada.Text_IO;

with Philosophers.Internals;  use Philosophers.Internals;

package body Philosophers is

   Update : Update_Access;


   package Id_Management is

      function Get_Id return Philosopher_Id;

   end;
   use Id_Management;

   package body Id_Management is

      Id : Natural := 0;

      function Get_Id return Philosopher_Id is
      begin
         Id := Id + 1;
         return Id;
      end;

   end Id_Management;



   task type Philosopher_Task_Type (Id : Philosopher_Id := Get_Id);

   type Philosopher_Task_Array is
      array (Philosopher_Id) of Philosopher_Task_Type;

   Philosopher_Tasks : Philosopher_Task_Array;



   type Duration_Array is
      array (Philosopher_Id) of Duration;

   Delay_Times : Duration_Array;


   protected Random_Delay is

      procedure Get (Id : in Philosopher_Id);

      procedure Initialize;

   private

      G : Generator;

   end Random_Delay;



   procedure Start
     (Update : in Update_Access) is
   begin

      Ada.Text_IO.Put_Line
        ("Using suspension objects to wait for " &
         "chopsticks and display device.");

      Philosophers.Update := Update;

      Random_Delay.Initialize;

      for Id in Philosopher_Id loop
         Set_True (Semaphores (Id));
      end loop;

   end Start;


   function Get_Delay (Id : Philosopher_Id) return Duration is
   begin
      return Delay_Times (Id);
   end;


   type Boolean_Array is array (Philosopher_Id) of Boolean;

   protected Chopsticks is

      procedure Pick_Up
       (Id      : in     Philosopher_Id;
        Success :    out Boolean);

      procedure Put_Down
        (Id : in Philosopher_Id);

   private

      Available : Boolean_Array := (others => True);

   end Chopsticks;



   task body Philosopher_Task_Type is

      Delay_Time : Duration renames Delay_Times (Id);

      Semaphore : Suspension_Object renames Semaphores (Id);

      Picked_Up_Chopsticks : Boolean;

   begin

      Suspend_Until_True (Semaphore);

      Update (Id, Breathing);

      for I in 1 .. 5 loop

         loop
            Update (Id, Picking_Up);
            Chopsticks.Pick_Up (Id, Picked_Up_Chopsticks);
            exit when Picked_Up_Chopsticks;
            Update (Id, Suspending);
            Suspend_Until_True (Semaphore);
         end loop;

         Random_Delay.Get (Id);
         Update (Id, Eating);
         delay Delay_Time;
         Update (Id, Done_Eating);
         Chopsticks.Put_Down (Id);

         Random_Delay.Get (Id);
         Update (Id, Thinking);
         delay Delay_Time;
         Update (Id, Done_Thinking);

      end loop;

      Update (Id, Dying);

      delay 60.0; -- hack to work around error in my RTS

   end Philosopher_Task_Type;


   protected body Chopsticks is

      procedure Pick_Up
        (Id      : in     Philosopher_Id;
         Success :    out Boolean) is

         Next : constant Philosopher_Id := Id mod 5 + 1;

      begin

         if Available (Id) and Available (Next) then

            Available (Id) := False;
            Available (Next) := False;

            Success := True;

         else

            Set_False (Semaphores (Id));
            Success := False;

         end if;

      end Pick_Up;


      procedure Put_Down
        (Id : in Philosopher_Id) is

         Prev : constant Philosopher_Id := (Id + 3) mod 5 + 1;
         Next : constant Philosopher_Id := Id mod 5 + 1;

      begin

         Available (Id) := True;
         Available (Next) := True;

         Set_True (Semaphores (Prev));
         Set_True (Semaphores (Next));

      end Put_Down;


   end Chopsticks;


   protected body Random_Delay is

      procedure Get (Id : in Philosopher_Id) is

         F : constant Float := Random (G);
      begin
         Delay_Times (Id) := 10 * Duration (F);
      end;

      procedure Initialize is
      begin
         Reset (G);
      end;

   end Random_Delay;


end Philosophers;

package Philosophers is

   subtype Philosopher_Id is Positive range 1 .. 5;

   type State_Type is
      (Breathing,
       Thinking,
       Done_Thinking,
       Picking_Up,
       Suspending,
       Eating,
       Done_Eating,
       Dying);

   type Update_Access is
      access procedure (Id    : in Philosopher_Id;
                        State : in State_Type);

   procedure Start (Update : in Update_Access);

   function Get_Delay (Id : Philosopher_Id) return Duration;

end Philosophers;

package body Queues.Bounded is

   procedure Add
     (Item : in     Item_Type;
      To   : in out Queue_Type) is
   begin
      pragma Assert (To.Length < To.Size);
      To.Items (To.B) := Item;
      To.B := To.B mod To.Size + 1;
      To.Length := To.Length + 1;
   end Add;


   procedure Pop
     (Queue : in out Queue_Type) is
   begin
      pragma Assert (Queue.Length > 0);
      Queue.F := Queue.F mod Queue.Size + 1;
      Queue.Length := Queue.Length - 1;
   end;


   function Get_Front
     (Queue : Queue_Type) return Item_Type is
   begin
      pragma Assert (Queue.Length > 0);
      return Queue.Items (Queue.F);
   end;


   function Is_Empty
     (Queue : Queue_Type) return Boolean is
   begin
      return Queue.Length = 0;
   end;


   function Is_Full
     (Queue : Queue_Type) return Boolean is
   begin
      return Queue.Length = Queue.Size;
   end;


end Queues.Bounded;




generic
   type Item_Type is private;
package Queues.Bounded is

   type Queue_Type (Size : Positive) is limited private;

   procedure Add
     (Item : in     Item_Type;
      To   : in out Queue_Type);

   procedure Pop
     (Queue : in out Queue_Type);

   function Get_Front
     (Queue : Queue_Type) return Item_Type;

   function Is_Empty
     (Queue : Queue_Type) return Boolean;

   function Is_Full
     (Queue : Queue_Type) return Boolean;

private

   type Item_Array is array (Positive range <>) of Item_Type;

   type Queue_Type (Size : Positive) is
      limited record
         Items  : Item_Array (1 .. Size);
         Length : Natural := 0;
         F, B   : Positive := 1;
      end record;

end Queues.Bounded;




package Queues is

   pragma Pure;

end Queues;
package body Semaphores.Bounded is

   protected body Semaphore_Type is


      procedure Wait (SO : in Suspension_Object_Access) is
      begin
         if In_Use then
            Add (SO, To => Queue);
            Set_False (SO.all);
         else
            In_Use := True;
            Set_True (SO.all);
         end if;
      end Wait;


      procedure Signal is
      begin
         pragma Assert (In_Use);

         if Is_Empty (Queue) then
            In_Use := False;
         else
            Set_True (Get_Front (Queue).all);
            Pop (Queue);
         end if;
      end Signal;


   end Semaphore_Type;

end Semaphores.Bounded;









with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
with Queues.Bounded;

pragma Elaborate (Queues.Bounded);

package Semaphores.Bounded is

   pragma Elaborate_Body;

   type Suspension_Object_Access is
      access all Suspension_Object;

   package SO_Queues is
     new Queues.Bounded (Suspension_Object_Access);
   use SO_Queues;


   protected type Semaphore_Type (Size : Positive) is

      procedure Wait (SO : in Suspension_Object_Access);

      procedure Signal;

   private

      Queue : Queue_Type (Size);

      In_Use : Boolean := False;

   end Semaphore_Type;

end Semaphores.Bounded;


package Semaphores is

   pragma Pure;

end Semaphores;
with Philosophers.Line_Views; use Philosophers;

procedure Test_Philosophers is
begin
   Start (Line_Views.Update'Access);
end;