I'm Queueless, or, Suspension Objects Instead of Entries

In previous articles we picked up chopsticks by waiting in the Pick_Up
entry queue of the Chopsticks protected object.  Here we implement the
Pick_Up operation as a protected procedure only, and use a suspension
object to keep the philosopher task waiting when chopsticks aren't
immediately available.

This new algorithm for picking up chopsticks is not unlike the classic
test-and-set loop used to claim ownership of a resource.  The task tries
to pick up the chopsticks.  If it was not successful, the task suspends
itself on a suspension object, and tries again later when its neighbor
puts down its chopsticks.

Implementation

The Pick_Up operation is implemented as a protected procedure that
returns a value indicating whether the operation was successful:

   protected Chopsticks is

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

      ...

   end Chopsticks;


The philosopher task enters a loop in which it keeps trying to pick up
chopsticks, exiting when it has been successful:

   task body Philosopher_Task_Type is

      ...

      Picked_Up_Chopsticks : Boolean;

   begin

     ...

       loop

          Chopsticks.Pick_Up (Id, Picked_Up_Chopsticks);

          exit when Picked_Up_Chopsticks;

          Suspend_Until_True (Semaphore);

       end loop;


There is an array of suspension objects, one for each task:

   type Suspension_Object_Array is
      array (Philosopher_Id) of Suspension_Object;

   Semaphores : Suspension_Object_Array;


If the task is not immediately successful in picking up chopsticks, it
suspends itself by calling the Suspend_Until_True operation of the
semaphore assigned to that task.  It will try again later when its
neighbor puts her chopsticks down.

When a task puts chopsticks down, it marks the chopsticks as available,
and notifies its neighbors:

      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;


Setting the semaphore to True wakes up the task suspended on the
semaphore.  The task will then try again to pick up the chopsticks.

If both chopsticks are available, the Pick_Up operation marks them as
now unavailable.  Otherwise, it just sets the calling task's semaphore
back to False:

      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;


If unable to pick up both chopsticks, the task will suspend when it
calls Suspend_Until_True, because the semaphore was set to False.

(Although the operations Set_True and Set_False are atomic operations,
those operations must be called by the protected object.  In between the
time the task tries unsuccessfully to pick up chopsticks and the time it
suspends itself, its neighbor may have put the chopsticks back down.
The task can't set the semaphore back to False itself, outside the
protected object, because that could clobber a signal just sent by the
neighbor.)

The last thing to mention concerns task initialization.  Recall that we
have to keep the tasks waiting following their activation, until the
package has been properly initialized.

In earlier implementations, the tasks waited for a signal sent by the
Start procedure.  The signal was implemented using a protected object.
However, we already have suspension objects, so we might as use them to
suspend the tasks during initialization too.

The first thing the task does when it activates is suspend on its
suspension object:

   task body Philosopher_Task_Type is

      ...

   begin

      Suspend_Until_True (Semaphore);

      ...

   end Philosopher_Task_Type;


Suspension objects are initialized to False, per RM95 D.10 (6), so the
task definitely will suspend.

Once the internal state has been updated, the Start procedure sets all
suspension objects to True, which resumes all the suspended tasks:


   procedure Start
     (Update : in Update_Access) is
   begin

      ...

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

   end Start;


Source code ready for GNAT Chop:

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

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 Suspension_Object_Array is
      array (Philosopher_Id) of Suspension_Object;

   Semaphores : Suspension_Object_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 instead of entry queue.");

      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

   pragma Elaborate_Body;

   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;